Index: LMDZ5/branches/testing/libf/dyn3d/advtrac.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/advtrac.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/advtrac.F90	(revision 2298)
@@ -9,5 +9,5 @@
   !            M.A Filiberti (04/2002)
   !
-  USE infotrac, ONLY: nqtot, iadv
+  USE infotrac, ONLY: nqtot, iadv,nqperes,ok_iso_verif
   USE control_mod, ONLY: iapp_tracvl, day_step
 
@@ -79,6 +79,6 @@
 
   IF(iadvtr.EQ.0) THEN
-     CALL initial0(ijp1llm,pbaruc)
-     CALL initial0(ijmllm,pbarvc)
+     pbaruc(:,:)=0
+     pbarvc(:,:)=0
   ENDIF
 
@@ -223,5 +223,11 @@
      !     Appel des sous programmes d'advection
      !-----------------------------------------------------------
-     do iq=1,nqtot
+
+     if (ok_iso_verif) then
+           write(*,*) 'advtrac 227'
+           call check_isotopes_seq(q,ip1jmp1,'advtrac 162')
+     endif !if (ok_iso_verif) then
+
+     do iq=1,nqperes
         !        call clock(t_initial)
         if(iadv(iq) == 0) cycle 
@@ -230,6 +236,9 @@
         !   ----------------------------------------------------------------
         if(iadv(iq).eq.10) THEN
-           call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
-
+           ! CRisi: on fait passer tout q pour avoir acces aux fils
+           
+           !write(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
+           call vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
+           
            !   ----------------------------------------------------------------
            !   Schema "pseudo amont" + test sur humidite specifique
@@ -238,6 +247,8 @@
         else if(iadv(iq).eq.14) then
            !
-           CALL vlspltqs( q(1,1,1), 2., massem, wg , &
-                pbarug,pbarvg,dtvr,p,pk,teta )
+           !write(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
+           CALL vlspltqs( q, 2., massem, wg , &
+                pbarug,pbarvg,dtvr,p,pk,teta,iq)
+           
            !   ----------------------------------------------------------------
            !   Schema de Frederic Hourdin
@@ -388,4 +399,8 @@
      end DO
 
+     if (ok_iso_verif) then
+           write(*,*) 'advtrac 402'
+           call check_isotopes_seq(q,ip1jmp1,'advtrac 397')
+     endif !if (ok_iso_verif) then
 
      !------------------------------------------------------------------
Index: LMDZ5/branches/testing/libf/dyn3d/caladvtrac.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/caladvtrac.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/caladvtrac.F	(revision 2298)
@@ -53,5 +53,8 @@
       if (planet_type.eq."earth") then
 C initialisation
-        dq(:,:,1:2)=q(:,:,1:2)
+! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
+! isotopes
+!        dq(:,:,1:2)=q(:,:,1:2)
+        dq(:,:,1:nqtot)=q(:,:,1:nqtot)
        
 c  test des valeurs minmax
@@ -81,6 +84,8 @@
            ENDDO
           ENDDO
-          
-          CALL qminimum( q, 2, finmasse )
+
+          !write(*,*) 'caladvtrac 87'
+          CALL qminimum( q, nqtot, finmasse )
+          !write(*,*) 'caladvtrac 89'
 
           CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
@@ -92,5 +97,5 @@
           dtvrtrac = iapp_tracvl * dtvr
 c
-           DO iq = 1 , 2
+           DO iq = 1 , nqtot
             DO l = 1 , llm
              DO ij = 1,ip1jmp1
@@ -105,5 +110,5 @@
         if (planet_type.eq."earth") then
 ! Earth-specific treatment for the first 2 tracers (water)
-          dq(:,:,1:2)=0.
+          dq(:,:,1:nqtot)=0.
         endif ! of if (planet_type.eq."earth")
       ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
Index: LMDZ5/branches/testing/libf/dyn3d/calfis.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/calfis.F	(revision 2274)
+++ 	(revision )
@@ -1,666 +1,0 @@
-!
-! $Id$
-!
-C
-C
-      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)
-c
-c    Auteur :  P. Le Van, F. Hourdin 
-c   .........
-      USE infotrac, ONLY: nqtot, niadv, tname
-      USE control_mod, ONLY: planet_type, nsplit_phys
- 
-
-      IMPLICIT NONE
-c=======================================================================
-c
-c   1. rearrangement des tableaux et transformation
-c      variables dynamiques  >  variables physiques
-c   2. calcul des termes physiques
-c   3. retransformation des tendances physiques en tendances dynamiques
-c
-c   remarques:
-c   ----------
-c
-c    - les vents sont donnes dans la physique par leurs composantes 
-c      naturelles.
-c    - la variable thermodynamique de la physique est une variable
-c      intensive :   T 
-c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
-c    - les deux seules variables dependant de la geometrie necessaires
-c      pour la physique sont la latitude pour le rayonnement et 
-c      l'aire de la maille quand on veut integrer une grandeur 
-c      horizontalement.
-c    - les points de la physique sont les points scalaires de la 
-c      la dynamique; numerotation:
-c          1 pour le pole nord
-c          (jjm-1)*iim pour l'interieur du domaine
-c          ngridmx pour le pole sud
-c      ---> ngridmx=2+(jjm-1)*iim
-c
-c     Input :
-c     -------
-c       pucov           covariant zonal velocity
-c       pvcov           covariant meridional velocity 
-c       pteta           potential temperature
-c       pps             surface pressure
-c       pmasse          masse d'air dans chaque maille
-c       pts             surface temperature  (K)
-c       callrad         clef d'appel au rayonnement
-c
-c    Output :
-c    --------
-c        pdufi          tendency for the natural zonal velocity (ms-1)
-c        pdvfi          tendency for the natural meridional velocity 
-c        pdhfi          tendency for the potential temperature
-c        pdtsfi         tendency for the surface temperature
-c
-c        pdtrad         radiative tendencies  \  both input
-c        pfluxrad       radiative fluxes      /  and output
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "temps.h"
-
-      INTEGER ngridmx
-      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
-
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "iniprint.h"
-
-c    Arguments :
-c    -----------
-      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 dynamics grid
-
-      ! 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)
-
-
-c    Local variables :
-c    -----------------
-
-      INTEGER i,j,l,ig0,ig,iq,iiq
-      REAL zpsrf(ngridmx)
-      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
-      REAL zphi(ngridmx,llm),zphis(ngridmx)
-c
-      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
-      REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
-c
-      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
-      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
-c
-      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
-      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
-      REAL zdpsrf(ngridmx)
-c
-      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
-c
-      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
-c
-      
-      REAL SSUM
-
-      LOGICAL,SAVE :: firstcal=.true., debut=.true.
-!      REAL rdayvrai
-
-      LOGICAL tracerdyn
-
-c
-c-----------------------------------------------------------------------
-c
-c    1. Initialisations :
-c    --------------------
-c
-c
-      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
-         STOP
-        ENDIF
-      ELSE
-        debut = .FALSE.
-      ENDIF ! of IF (firstcal)
-
-c
-c
-c-----------------------------------------------------------------------
-c   40. transformation des variables dynamiques en variables physiques:
-c   ---------------------------------------------------------------
-
-c   41. pressions au sol (en Pascals)
-c   ----------------------------------
-
-       
-      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)
-
-
-c   42. pression intercouches :
-c
-c   -----------------------------------------------------------------
-c     .... zplev  definis aux (llm +1) interfaces des couches  ....
-c     .... zplay  definis aux (  llm )    milieux des couches  .... 
-c   -----------------------------------------------------------------
-
-c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
-c
-       unskap   = 1./ kappa
-c
-      DO l = 1, llmp1
-        zplev( 1,l ) = pp(1,1,l)
-        ig0 = 2
-          DO j = 2, jjm
-             DO i =1, iim
-              zplev( ig0,l ) = pp(i,j,l)
-              ig0 = ig0 +1
-             ENDDO
-          ENDDO
-        zplev( ngridmx,l ) = pp(1,jjp1,l)
-      ENDDO
-c
-c
-
-c   43. temperature naturelle (en K) et pressions milieux couches .
-c   ---------------------------------------------------------------
-
-      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
-
-c   43.bis traceurs
-c   ---------------
-c
-      DO iq=1,nqtot
-          iiq=niadv(iq) 
-         DO l=1,llm
-            zqfi(1,l,iq) = pq(1,1,l,iiq)
-            ig0          = 2
-            DO j=2,jjm
-               DO i = 1, iim
-                  zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
-                  ig0             = ig0 + 1
-               ENDDO
-            ENDDO
-            zqfi(ig0,l,iq) = pq(1,jjp1,l,iiq)
-         ENDDO
-      ENDDO
-
-c   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")
-
-
-c   Geopotentiel calcule par rapport a la surface locale:
-c   -----------------------------------------------------
-
-      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
-
-c   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
-c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux 
-c    de masse est calclue dans advtrac.F  
-c      DO l=1,llm
-c        pvervel(1,l)=pw(1,1,l) * g /apoln
-c        ig0=2
-c       DO j=2,jjm
-c           DO i = 1, iim
-c              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
-c              ig0 = ig0 + 1
-c           ENDDO
-c       ENDDO
-c        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
-c      ENDDO
-
-c
-c   45. champ u:
-c   ------------
-
-      DO 50 l=1,llm
-
-         DO 25 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 10 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) )
-10         CONTINUE
-25      CONTINUE
-
-50    CONTINUE
-
-
-c   46.champ v:
-c   -----------
-
-      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
-         ENDDO
-      ENDDO
-
-
-c   47. champs de vents aux pole nord   
-c   ------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        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
-
-      ENDDO
-
-
-c   48. champs de vents aux pole sud:
-c   ---------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        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
-
-      ENDDO
-c
-c On change de grille, dynamique vers physiq, pour le flux de masse verticale
-      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
-
-c-----------------------------------------------------------------------
-c   Appel de la physique:
-c   ---------------------
-
-
-
-!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
-      zdt_split=dtphys/nsplit_phys
-      zdufic(:,:)=0.
-      zdvfic(:,:)=0.
-      zdtfic(:,:)=0.
-      zdqfic(:,:,:)=0.
-
-#ifdef CPP_PHYS
-
-       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 physiq (ngridmx,
-     .             llm,
-     .             debut_split,
-     .             lafin_split,
-     .             jD_cur,
-     .             jH_cur_split,
-     .             zdt_split,
-     .             zplev,
-     .             zplay,
-     .             zphi,
-     .             zphis,
-     .             presnivs,
-     .             zufi,
-     .             zvfi,
-     .             ztfi,
-     .             zqfi,
-     .             flxwfi,
-     .             zdufi,
-     .             zdvfi,
-     .             zdtfi,
-     .             zdqfi,
-     .             zdpsrf,
-     .             pducov)
-
-      else if ( planet_type=="generic" ) then
-
-         CALL physiq (ngridmx,     !! ngrid
-     .             llm,            !! nlayer
-     .             nqtot,          !! nq
-     .             tname,          !! 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
-
-#endif
-! of #ifdef CPP_PHYS
-
-      zdufi(:,:)=zdufic(:,:)/nsplit_phys
-      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
-      zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
-      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
-
-
-500   CONTINUE
-
-c-----------------------------------------------------------------------
-c   transformation des tendances physiques en tendances dynamiques:
-c   ---------------------------------------------------------------
-
-c  tendance sur la pression :
-c  -----------------------------------
-
-      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
-c
-c   62. enthalpie potentielle
-c   ---------------------
-
-      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
-
-
-c   62. humidite specifique
-c   ---------------------
-! 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
-
-c   63. traceurs
-c   ------------
-C     initialisation des tendances
-      pdqfi(:,:,:,:)=0.
-C
-      DO iq=1,nqtot
-         iiq=niadv(iq)
-         DO l=1,llm
-            DO i=1,iip1
-               pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
-               pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq)
-            ENDDO
-            DO j=2,jjm
-               ig0=1+(j-2)*iim
-               DO i=1,iim
-                  pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq)
-               ENDDO
-               pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq)
-            ENDDO
-         ENDDO
-      ENDDO
-
-c   65. champ u:
-c   ------------
-
-      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
-
-
-c   67. champ v:
-c   ------------
-
-      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
-
-
-c   68. champ v pres des poles:
-c   ---------------------------
-c      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
-
-c-----------------------------------------------------------------------
-
-700   CONTINUE
- 
-      firstcal = .FALSE.
-
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3d/ce0l.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/ce0l.F90	(revision 2274)
+++ 	(revision )
@@ -1,107 +1,0 @@
-!
-! $Id$
-!
-!-------------------------------------------------------------------------------
-!
-PROGRAM ce0l
-!-------------------------------------------------------------------------------
-! Purpose: Calls etat0, creates initial states and limit_netcdf
-!
-!     interbar=.T. for barycentric interpolation inter_barxy
-!     extrap  =.T. for data extrapolation, like for the SSTs when file does not
-!                  contain ocean points only.
-!     oldice  =.T. for old-style ice, obtained using grille_m (grid_atob).
-!     masque is created in etat0, passed to limit to ensure consistancy.
-!-------------------------------------------------------------------------------
-  USE control_mod
-#ifdef CPP_EARTH
-! This prog. is designed to work for Earth
-  USE dimphy
-  USE comgeomphy
-  USE infotrac
-  USE indice_sol_mod
-
-#ifdef CPP_IOIPSL
-  USE ioipsl, ONLY: ioconf_calendar
-#endif
-
-#endif
-  IMPLICIT NONE
-#ifndef CPP_EARTH
-#include "iniprint.h"
-  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
-#else
-!-------------------------------------------------------------------------------
-! Local variables:
-  LOGICAL, PARAMETER :: interbar=.TRUE., extrap=.FALSE., oldice=.FALSE.
-#include "dimensions.h"
-#include "paramet.h"
-!#include "indicesol.h"
-#include "iniprint.h"
-#include "temps.h"
-#include "logic.h"
-  REAL,    DIMENSION(iip1,jjp1) :: masque
-  CHARACTER(LEN=15)             :: calnd
-  REAL,    DIMENSION(iip1,jjp1) :: phis ! geopotentiel au sol
-!-------------------------------------------------------------------------------
-  CALL conf_gcm( 99, .TRUE. )
-
-  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
-  WRITE(lunout,*)'---> klon=',klon
-  CALL InitComgeomphy
-
-#ifdef CPP_IOIPSL
-  SELECT CASE(calend)
-    CASE('earth_360d');CALL ioconf_calendar('360d');      calnd='a 360 jours/an'
-    CASE('earth_365d');CALL ioconf_calendar('noleap');    calnd='a 365 jours/an'
-    CASE('earth_366d');CALL ioconf_calendar('366d');      calnd='bissextile'
-    CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien'
-    CASE('standard');  CALL ioconf_calendar('gregorian'); calnd='gregorien'
-    CASE('julian');    CALL ioconf_calendar('julian');    calnd='julien'
-    CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian')
-  !--- DC Bof...  => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian
-    CASE DEFAULT
-      CALL abort_gcm('ce0l','Mauvais choix de calendrier',1)
-  END SELECT
-  WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd)
-#endif
-
-  IF (type_trac == 'inca') THEN
-#ifdef INCA
-    CALL init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday)
-    CALL init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
-    WRITE(lunout,*)'nbtr =' , nbtr 
-#endif
-  END IF
-
-  WRITE(lunout,'(//)')
-  WRITE(lunout,*) '  *********************  '
-  WRITE(lunout,*) '  ***  etat0_netcdf ***  '
-  WRITE(lunout,*) '  *********************  '
-  WRITE(lunout,'(//)')
-  WRITE(lunout,*) ' interbar = ',interbar
-  CALL etat0_netcdf(interbar,masque,phis,ok_etat0)
-
-  IF(ok_limit) THEN
-  WRITE(lunout,'(//)')
-  WRITE(lunout,*) '  *********************  '
-  WRITE(lunout,*) '  ***  Limit_netcdf ***  '
-  WRITE(lunout,*) '  *********************  '
-  WRITE(lunout,'(//)')
-  CALL limit_netcdf(interbar,extrap,oldice,masque)
-  END IF
-
-  
-  WRITE(lunout,'(//)')
-  WRITE(lunout,*) '  ***************************  '
-  WRITE(lunout,*) '  ***  grilles_gcm_netcdf ***  '
-  WRITE(lunout,*) '  ***************************  '
-  WRITE(lunout,'(//)')
-  CALL grilles_gcm_netcdf_sub(masque,phis)
-
-#endif
-! of #ifndef CPP_EARTH #else
-
-END PROGRAM ce0l
-!
-!-------------------------------------------------------------------------------
Index: LMDZ5/branches/testing/libf/dyn3d/check_isotopes.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/check_isotopes.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d/check_isotopes.F	(revision 2298)
@@ -0,0 +1,201 @@
+        subroutine check_isotopes_seq(q,ip1jmp1,err_msg)
+        USE infotrac
+        implicit none
+
+#include "dimensions.h"
+
+        ! inputs
+        integer ip1jmp1
+        real q(ip1jmp1,llm,nqtot)
+        character*(*) err_msg ! message d''erreur à afficher
+
+        ! locals
+        integer ixt,phase,k,i,iq,iiso,izone,ieau,iqeau
+        real xtractot,xiiso
+        real borne
+        real qmin
+        real errmax ! erreur maximale en absolu.
+        real errmaxrel ! erreur maximale en relatif autorisée
+        real deltaDmax,deltaDmin
+        real ridicule
+        parameter (borne=1e19)
+        parameter (errmax=1e-8)
+        parameter (errmaxrel=1e-3)
+        parameter (qmin=1e-11)
+        parameter (deltaDmax=200.0,deltaDmin=-999.9)
+        parameter (ridicule=1e-12)
+        real deltaD
+
+        if (ok_isotopes) then
+
+        write(*,*) 'check_isotopes 31: err_msg=',err_msg
+        ! verifier que rien n'est NaN
+        do ixt=1,ntraciso
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+            do k=1,llm
+              DO i = 1,ip1jmp1
+                if ((q(i,k,iq).gt.-borne).and.
+     :            (q(i,k,iq).lt.borne)) then
+                else !if ((x(ixt,i,j).gt.-borne).and.
+                  write(*,*) 'erreur detectee par iso_verif_noNaN:'
+                  write(*,*) err_msg
+                  write(*,*) 'q,i,k,iq=',q(i,k,iq),i,k,iq
+                  write(*,*) 'borne=',borne
+                  stop
+                endif  !if ((x(ixt,i,j).gt.-borne).and.
+              enddo !DO i = 1,ip1jmp1
+            enddo !do k=1,llm
+          enddo !do phase=1,nqo
+        enddo !do ixt=1,ntraciso
+
+        !write(*,*) 'check_isotopes 52'
+        ! verifier que l'eau normale est OK
+        if (use_iso(1)) then
+          ixt=indnum_fn_num(1)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+            do k=1,llm
+            DO i = 1,ip1jmp1  
+              if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+     :          (abs((q(i,k,phase)-q(i,k,iq))/
+     :           max(max(abs(q(i,k,phase)),abs(q(i,k,iq))),1e-18))
+     :           .gt.errmaxrel)) then
+                  write(*,*) 'erreur detectee par iso_verif_egalite:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase=',ixt,phase
+                  write(*,*) 'q,iq,i,k=',q(i,k,iq),iq,i,k
+                  write(*,*) 'q(i,k,phase)=',q(i,k,phase)
+                  stop
+              endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+              ! bidouille pour éviter divergence:
+              q(i,k,iq)= q(i,k,phase) 
+            enddo ! DO i = 1,ip1jmp1
+            enddo !do k=1,llm
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(1)) then
+        
+        !write(*,*) 'check_isotopes 78'
+        ! verifier que HDO est raisonable
+        if (use_iso(2)) then
+          ixt=indnum_fn_num(2)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+            do k=1,llm
+            DO i = 1,ip1jmp1
+            if (q(i,k,iq).gt.qmin) then
+             deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(2)-1)*1000
+             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur detectee par iso_verif_aberrant:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase=',ixt,phase
+                  write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
+                  write(*,*) 'q=',q(i,k,:)
+                  write(*,*) 'deltaD=',deltaD
+                  stop
+             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+            endif !if (q(i,k,iq).gt.qmin) then
+            enddo !DO i = 1,ip1jmp1
+            enddo !do k=1,llm
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(2)) then
+
+        !write(*,*) 'check_isotopes 103'
+        ! verifier que O18 est raisonable
+        if (use_iso(3)) then
+          ixt=indnum_fn_num(3)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+            do k=1,llm
+            DO i = 1,ip1jmp1
+            if (q(i,k,iq).gt.qmin) then
+             deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(3)-1)*1000
+             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur detectee iso_verif_aberrant O18:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase=',ixt,phase
+                  write(*,*) 'q,iq,i,k,=',q(i,k,phase),iq,i,k
+                  write(*,*) 'xt=',q(i,k,:)
+                  write(*,*) 'deltaO18=',deltaD
+                  stop
+             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+            endif !if (q(i,k,iq).gt.qmin) then
+            enddo !DO i = 1,ip1jmp1
+            enddo !do k=1,llm
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(2)) then
+
+
+        !write(*,*) 'check_isotopes 129'
+        if (ok_isotrac) then
+
+          if (use_iso(2).and.use_iso(1)) then
+            do izone=1,ntraceurs_zone
+             ixt=index_trac(izone,indnum_fn_num(2))
+             ieau=index_trac(izone,indnum_fn_num(1))
+             do phase=1,nqo
+               iq=iqiso(ixt,phase)
+               iqeau=iqiso(ieau,phase)
+               do k=1,llm
+                DO i = 1,ip1jmp1
+                if (q(i,k,iq).gt.qmin) then
+                 deltaD=(q(i,k,iq)/q(i,k,iqeau)/tnat(2)-1)*1000
+                 if ((deltaD.gt.deltaDmax).or.
+     &                   (deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur dans iso_verif_aberrant trac:'
+                  write(*,*) err_msg
+                  write(*,*) 'izone,phase=',izone,phase
+                  write(*,*) 'ixt,ieau=',ixt,ieau
+                  write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
+                  write(*,*) 'deltaD=',deltaD
+                  stop
+                 endif !if ((deltaD.gt.deltaDmax).or.
+                endif !if (q(i,k,iq).gt.qmin) then
+                enddo !DO i = 1,ip1jmp1
+                enddo  ! do k=1,llm
+              enddo ! do phase=1,nqo    
+            enddo !do izone=1,ntraceurs_zone
+          endif !if (use_iso(2).and.use_iso(1)) then
+
+          do iiso=1,niso
+           do phase=1,nqo
+              iq=iqiso(iiso,phase)
+              do k=1,llm
+                DO i = 1,ip1jmp1
+                   xtractot=0.0
+                   xiiso=q(i,k,iq)
+                   do izone=1,ntraceurs_zone
+                      iq=iqiso(index_trac(izone,iiso),phase)
+                      xtractot=xtractot+ q(i,k,iq)
+                   enddo !do izone=1,ntraceurs_zone
+                   if ((abs(xtractot-xiiso).gt.errmax).and.
+     :                  (abs(xtractot-xiiso)/
+     :                  max(max(abs(xtractot),abs(xiiso)),1e-18)
+     :                  .gt.errmaxrel)) then
+                  write(*,*) 'erreur detectee par iso_verif_traceurs:'
+                  write(*,*) err_msg
+                  write(*,*) 'iiso,phase=',iiso,phase
+                  write(*,*) 'i,k,=',i,k
+                  write(*,*) 'q(i,k,:)=',q(i,k,:)
+                  stop
+                 endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+                  
+                 ! bidouille pour éviter divergence:
+                 if (abs(xtractot).gt.ridicule) then
+                   do izone=1,ntraceurs_zone
+                     ixt=index_trac(izone,iiso) 
+                     q(i,k,iq)=q(i,k,iq)/xtractot*xiiso
+                   enddo !do izone=1,ntraceurs_zone                
+                  endif !if ((abs(xtractot).gt.ridicule) then
+                enddo !DO i = 1,ip1jmp1
+              enddo !do k=1,llm
+           enddo !do phase=1,nqo
+          enddo !do iiso=1,niso
+
+        endif !if (ok_isotrac) then
+
+        endif ! if (ok_isotopes)
+        !write(*,*) 'check_isotopes 198'
+        
+        end
+
Index: LMDZ5/branches/testing/libf/dyn3d/conf_gcm.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/conf_gcm.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/conf_gcm.F90	(revision 2298)
@@ -46,5 +46,4 @@
   LOGICAL  fxyhypbb, ysinuss
   INTEGER i
-  LOGICAL use_filtre_fft
 
   !  -------------------------------------------------------------------
@@ -89,7 +88,7 @@
 
   !Config  Key  = prt_level
-  !Config  Desc = niveau d'impressions de débogage
+  !Config  Desc = niveau d'impressions de d\'ebogage
   !Config  Def  = 0
-  !Config  Help = Niveau d'impression pour le débogage
+  !Config  Help = Niveau d'impression pour le d\'ebogage
   !Config         (0 = minimum d'impression)
   prt_level = 0
@@ -733,5 +732,5 @@
      dzoomy = 0.2
      CALL getin('dzoomy',dzoomy)
-     call assert(dzoomy< 1, "conf_gcm: dzoomy must be < 1")
+     call assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
 
      !Config  Key  = taux
@@ -810,23 +809,8 @@
      CALL getin('ok_dyn_ave',ok_dyn_ave) 
 
-     !Config  Key  = use_filtre_fft
-     !Config  Desc = flag d'activation des FFT pour le filtre
-     !Config  Def  = false
-     !Config  Help = permet d'activer l'utilisation des FFT pour effectuer
-     !Config         le filtrage aux poles.
-     ! Le filtre fft n'est pas implemente dans dyn3d 
-     use_filtre_fft=.FALSE.
-     CALL getin('use_filtre_fft',use_filtre_fft)
-
-     IF (use_filtre_fft) THEN
-        write(lunout,*)'STOP !!!'
-        write(lunout,*)'use_filtre_fft n est pas implemente dans dyn3d'
-        STOP 1
-     ENDIF
-
      !Config key = ok_strato
      !Config  Desc = activation de la version strato
      !Config  Def  = .FALSE.
-     !Config  Help = active la version stratosphérique de LMDZ de F. Lott
+     !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
 
      ok_strato=.FALSE.
Index: LMDZ5/branches/testing/libf/dyn3d/dynetat0.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/dynetat0.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/dynetat0.F	(revision 2298)
@@ -297,4 +297,19 @@
            write(lunout,*)"          Il est donc initialise a zero"
            q(:,:,:,iq)=0.
+
+           ! CRisi: pour les isotopes, on peut faire init théorique
+           ! distill de Rayleigh très simplifiée
+           if (ok_isotopes) then
+              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.0)) then
+                q(:,:,:,iq)=q(:,:,:,iqpere(iq))                         
+     &                   *tnat(iso_num(iq))                             
+     &                   *(q(:,:,:,iqpere(iq))/30.e-3)                  
+     &                   **(alpha_ideal(iso_num(iq))-1)
+              endif
+              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.1)) then
+                  q(:,:,:,iq)=q(:,:,:,iqiso(iso_indnum(iq),
+     &                   phase_num(iq)))
+              endif  
+           endif !if (ok_isotopes) then 
         ELSE
            ierr = NF90_GET_VAR(nid, nvarid, q(:,:,:,iq))
Index: LMDZ5/branches/testing/libf/dyn3d/fluxstokenc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/fluxstokenc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/fluxstokenc.F	(revision 2298)
@@ -83,8 +83,8 @@
 
       IF(iadvtr.EQ.0) THEN
-         CALL initial0(ijp1llm,phic)
-         CALL initial0(ijp1llm,tetac)
-         CALL initial0(ijp1llm,pbaruc)
-         CALL initial0(ijmllm,pbarvc)
+         phic(:,:)=0
+         tetac(:,:)=0
+         pbaruc(:,:)=0
+         pbarvc(:,:)=0
       ENDIF
 
Index: LMDZ5/branches/testing/libf/dyn3d/gcm.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/gcm.F	(revision 2274)
+++ 	(revision )
@@ -1,493 +1,0 @@
-!
-! $Id$
-!
-c
-c
-      PROGRAM gcm
-
-#ifdef CPP_IOIPSL
-      USE IOIPSL
-#else
-! if not using IOIPSL, we still need to use (a local version of) getin
-      USE ioipsl_getincom
-#endif
-
-
-#ifdef CPP_XIOS
-    ! ug Pour les sorties XIOS
-	USE wxios
-#endif
-
-      USE filtreg_mod
-      USE infotrac
-      USE control_mod
-
-#ifdef INCA
-! Only INCA needs these informations (from the Earth's physics)
-      USE indice_sol_mod
-      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
-#endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 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
-#ifdef CPP_PHYS
-!      USE dimphy
-!      USE comgeomphy
-#endif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      IMPLICIT NONE
-
-c      ......   Version  du 10/01/98    ..........
-
-c             avec  coordonnees  verticales hybrides 
-c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   GCM LMD nouvelle grille
-c
-c=======================================================================
-c
-c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
-c      et possibilite d'appeler une fonction f(y)  a derivee tangente
-c      hyperbolique a la  place de la fonction a derivee sinusoidale.
-c  ... Possibilite de choisir le schema pour l'advection de
-c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
-c
-c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
-c      Pour Van-Leer iadv=10
-c
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comdissnew.h"
-#include "comvert.h"
-#include "comgeom.h"
-#include "logic.h"
-#include "temps.h"
-!!!!!!!!!!!#include "control.h"
-#include "ener.h"
-#include "description.h"
-#include "serre.h"
-!#include "com_io_dyn.h"
-#include "iniprint.h"
-#include "tracstoke.h"
-#ifdef INCA
-! Only INCA needs these informations (from the Earth's physics)
-!#include "indicesol.h"
-#endif
-
-      REAL zdtvr
-
-c   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
-
-c variables dynamiques intermediaire pour le transport
-
-c   variables pour le fichier histoire
-      REAL dtav      ! intervalle de temps elementaire
-
-      REAL time_0
-
-      LOGICAL lafin
-      INTEGER ij,iq,l,i,j
-
-
-      real time_step, t_wrt, t_ops
-
-      LOGICAL first
-
-!      LOGICAL call_iniphys
-!      data call_iniphys/.true./
-
-c+jld variables test conservation energie
-c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
-C     Tendance de la temp. potentiel d (theta)/ d t due a la 
-C     tansformation d'energie cinetique en energie thermique
-C     cree par la dissipation
-      REAL dhecdt(ip1jmp1,llm)
-c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
-c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
-      CHARACTER (len=15) :: ztit
-c-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
-
-c-----------------------------------------------------------------------
-c   Initialisations:
-c   ----------------
-
-      abort_message = 'last timestep reached'
-      modname = 'gcm'
-      descript = 'Run GCM LMDZ'
-      lafin    = .FALSE.
-      dynhist_file = 'dyn_hist.nc'
-      dynhistave_file = 'dyn_hist_ave.nc'
-
-
-
-c----------------------------------------------------------------------
-c  lecture des fichiers gcm.def ou run.def
-c  ---------------------------------------
-c
-      CALL conf_gcm( 99, .TRUE.)
-      if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm",
-     s "iphysiq must be a multiple of iperiod", 1)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Initialisation de XIOS
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-#ifdef CPP_XIOS
-	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
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-c-----------------------------------------------------------------------
-c   Choix du calendrier
-c   -------------------
-
-c      calend = 'earth_365d'
-
-#ifdef CPP_IOIPSL
-      if (calend == 'earth_360d') then
-        call ioconf_calendar('360d')
-        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
-#endif
-c-----------------------------------------------------------------------
-
-      IF (type_trac == 'inca') THEN
-#ifdef INCA
-      call init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday, 
-     $        nbsrf, is_oce,is_sic,is_ter,is_lic)
-      call init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
-#endif
-      END IF
-c
-c
-c------------------------------------
-c   Initialisation partie parallele
-c------------------------------------
-
-c
-c
-c-----------------------------------------------------------------------
-c   Initialisation des traceurs
-c   ---------------------------
-c  Choix du nombre de traceurs et du schema pour l'advection
-c  dans fichier traceur.def, par default ou via INCA
-      call infotrac_init
-
-c Allocation de la tableau q : champs advectes   
-      allocate(q(ip1jmp1,llm,nqtot))
-
-c-----------------------------------------------------------------------
-c   Lecture de l'etat initial :
-c   ---------------------------
-
-c  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")
-        
-c       write(73,*) 'ucov',ucov
-c       write(74,*) 'vcov',vcov
-c       write(75,*) 'teta',teta
-c       write(76,*) 'ps',ps
-c       write(77,*) 'q',q
-
-      endif ! of if (read_start)
-
-      IF (type_trac == 'inca') THEN
-#ifdef INCA
-         call init_inca_dim(klon,llm,iim,jjm,
-     $        rlonu,rlatu,rlonv,rlatv)
-#endif
-      END IF
-
-
-c 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
-         CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
-      endif
-
-
-c-----------------------------------------------------------------------
-c   Lecture des parametres de controle pour la simulation :
-c   -------------------------------------------------------
-c  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
-
-C
-C on remet le calendrier \`a zero si demande
-c
-      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
-
-c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
-c        write(lunout,*)
-c     .  'GCM: Attention les dates initiales lues dans le fichier'
-c        write(lunout,*)
-c     .  ' restart ne correspondent pas a celles lues dans '
-c        write(lunout,*)' gcm.def'
-c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
-c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
-c        if (raz_date .ne. 1) then
-c          write(lunout,*)
-c     .    'GCM: On garde les dates du fichier restart'
-c        else
-c          annee_ref = anneeref
-c          day_ref = dayref
-c          day_ini = dayref
-c          itau_dyn = 0
-c          itau_phy = 0
-c          time_0 = 0.
-c          write(lunout,*)
-c     .   'GCM: On reinitialise a la date lue dans gcm.def'
-c        endif
-c      ELSE
-c        raz_date = 0
-c      endif
-
-#ifdef CPP_IOIPSL
-      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
-#else
-! Ehouarn: we still need to define JD_ref and JH_ref
-! and since we don't know how many days there are in a year
-! we set JD_ref to 0 (this should be improved ...)
-      jD_ref=0
-      jH_ref=0
-#endif
-
-
-      if (iflag_phys.eq.1) then
-      ! these initialisations have already been done (via iniacademic)
-      ! if running in SW or Newtonian mode
-c-----------------------------------------------------------------------
-c   Initialisation des constantes dynamiques :
-c   ------------------------------------------
-        dtvr = zdtvr
-        CALL iniconst
-
-c-----------------------------------------------------------------------
-c   Initialisation de la geometrie :
-c   --------------------------------
-        CALL inigeom
-
-c-----------------------------------------------------------------------
-c   Initialisation du filtre :
-c   --------------------------
-        CALL inifilr
-      endif ! of if (iflag_phys.eq.1)
-c
-c-----------------------------------------------------------------------
-c   Initialisation de la dissipation :
-c   ----------------------------------
-
-      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
-     *                tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
-
-c-----------------------------------------------------------------------
-c   Initialisation de la physique :
-c   -------------------------------
-
-      IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
-! Physics:
-#ifdef CPP_PHYS
-         CALL iniphysiq(iim,jjm,llm,daysec,day_ini,dtphys/nsplit_phys,
-     &                rlatu,rlonv,aire,cu,cv,rad,g,r,cpp,
-     &                iflag_phys)
-#endif
-      ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
-
-c  numero de stockage pour les fichiers de redemarrage:
-
-c-----------------------------------------------------------------------
-c   Initialisation des I/O :
-c   ------------------------
-
-
-      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//)
-
-#ifdef CPP_IOIPSL
-      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)
-#endif
-
-!      if (planet_type.eq."earth") then
-! Write an Earth-format restart file
-
-        CALL dynredem0("restart.nc", day_end, phis)
-!      endif
-
-      ecripar = .TRUE.
-
-#ifdef CPP_IOIPSL
-      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
-#endif
-! #endif of #ifdef CPP_IOIPSL
-
-c  Choix des frequences de stokage pour le offline
-c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
-c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
-      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
-      istphy=istdyn/iphysiq     
-
-
-c
-c-----------------------------------------------------------------------
-c   Integration temporelle du modele :
-c   ----------------------------------
-
-c       write(78,*) 'ucov',ucov
-c       write(78,*) 'vcov',vcov
-c       write(78,*) 'teta',teta
-c       write(78,*) 'ps',ps
-c       write(78,*) 'q',q
-
-
-      CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0)
-
-      END
-
Index: LMDZ5/branches/testing/libf/dyn3d/gcm.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/gcm.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d/gcm.F90	(revision 2298)
@@ -0,0 +1,499 @@
+!
+! $Id$
+!
+!
+!
+PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+  USE IOIPSL
+#else
+  ! if not using IOIPSL, we still need to use (a local version of) getin
+  USE ioipsl_getincom
+#endif
+
+
+#ifdef CPP_XIOS
+  ! ug Pour les sorties XIOS
+  USE wxios
+#endif
+
+  USE filtreg_mod
+  USE infotrac
+  USE control_mod
+
+#ifdef INCA
+  ! Only INCA needs these informations (from the Earth's physics)
+  USE indice_sol_mod
+  USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! 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
+#ifdef CPP_PHYS
+  !      USE dimphy
+  !      USE comgeomphy
+#endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  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 "comconst.h"
+  include "comdissnew.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "logic.h"
+  include "temps.h"
+!!!!!!!!!!!include "control.h"
+  include "ener.h"
+  include "description.h"
+  include "serre.h"
+  !include "com_io_dyn.h"
+  include "iniprint.h"
+  include "tracstoke.h"
+#ifdef INCA
+  ! Only INCA needs these informations (from the Earth's physics)
+  !include "indicesol.h"
+#endif
+
+  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
+  INTEGER ij,iq,l,i,j
+
+
+  real time_step, t_wrt, t_ops
+
+  LOGICAL first
+
+  !      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('FFT filter is not available in the ' &
+          // 'sequential version of the dynamics.', 1)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef CPP_XIOS
+  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'
+
+#ifdef CPP_IOIPSL
+  if (calend == 'earth_360d') then
+     call ioconf_calendar('360d')
+     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
+#endif
+  !-----------------------------------------------------------------------
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+     call init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday,  &
+          nbsrf, is_oce,is_sic,is_ter,is_lic)
+     call init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
+#endif
+  END IF
+  !
+  !
+  !------------------------------------
+  !   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 infotrac_init
+
+  ! 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)
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+     call init_inca_dim(klon,llm,iim,jjm, &
+          rlonu,rlatu,rlonv,rlatv)
+#endif
+  END IF
+
+
+  ! 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
+     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
+
+#ifdef CPP_IOIPSL
+  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
+#else
+  ! Ehouarn: we still need to define JD_ref and JH_ref
+  ! and since we don't know how many days there are in a year
+  ! we set JD_ref to 0 (this should be improved ...)
+  jD_ref=0
+  jH_ref=0
+#endif
+
+
+  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)
+
+  !-----------------------------------------------------------------------
+  !   Initialisation de la physique :
+  !   -------------------------------
+
+  IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
+     ! Physics:
+#ifdef CPP_PHYS
+     CALL iniphysiq(iim,jjm,llm,daysec,day_ini,dtphys/nsplit_phys, &
+          rlatu,rlonv,aire,cu,cv,rad,g,r,cpp, &
+          iflag_phys)
+#endif
+  ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
+
+  !  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//)
+
+#ifdef CPP_IOIPSL
+  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)
+#endif
+
+  !      if (planet_type.eq."earth") then
+  ! Write an Earth-format restart file
+
+  CALL dynredem0("restart.nc", day_end, phis)
+  !      endif
+
+  ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+  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
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+
+  !  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: LMDZ5/branches/testing/libf/dyn3d/guide_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/guide_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/guide_mod.F90	(revision 2298)
@@ -81,4 +81,5 @@
 ! Lecture des parametres:  
 ! ---------------------------------------------
+    call ini_getparam("nudging_parameters_out.txt")
 ! Variables guidees
     CALL getpar('guide_u',.true.,guide_u,'guidage de u')
@@ -109,5 +110,5 @@
     CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
     CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
-    
+
 ! Sauvegarde du for�age
     CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
@@ -147,4 +148,6 @@
     CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
 
+    call fin_getparam
+    
 ! ---------------------------------------------
 ! Determination du nombre de niveaux verticaux
@@ -156,6 +159,6 @@
           rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
           if (rcod.NE.NF_NOERR) THEN
-             print *,'Guide: probleme -> pas de fichier apbp.nc'
-             CALL abort_gcm(modname,abort_message,1)
+             CALL abort_gcm(modname, &
+                  'Guide: probleme -> pas de fichier apbp.nc',1)
           endif
        endif
@@ -165,6 +168,6 @@
                rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
                if (rcod.NE.NF_NOERR) THEN
-                  print *,'Guide: probleme -> pas de fichier u.nc'
-                  CALL abort_gcm(modname,abort_message,1)
+                  CALL abort_gcm(modname, &
+                       'Guide: probleme -> pas de fichier u.nc',1)
                endif
            endif
@@ -173,6 +176,6 @@
                rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
                if (rcod.NE.NF_NOERR) THEN
-                  print *,'Guide: probleme -> pas de fichier v.nc'
-                  CALL abort_gcm(modname,abort_message,1)
+                  CALL abort_gcm(modname, &
+                       'Guide: probleme -> pas de fichier v.nc',1)
                endif
            endif
@@ -181,6 +184,6 @@
                rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
                if (rcod.NE.NF_NOERR) THEN
-                  print *,'Guide: probleme -> pas de fichier T.nc'
-                  CALL abort_gcm(modname,abort_message,1)
+                  CALL abort_gcm(modname, &
+                       'Guide: probleme -> pas de fichier T.nc',1)
                endif
            endif
@@ -189,6 +192,6 @@
                rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
                if (rcod.NE.NF_NOERR) THEN
-                  print *,'Guide: probleme -> pas de fichier hur.nc'
-                  CALL abort_gcm(modname,abort_message,1)
+                  CALL abort_gcm(modname, &
+                       'Guide: probleme -> pas de fichier hur.nc',1)
                endif
            endif
@@ -198,6 +201,5 @@
     IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
     IF (error.NE.NF_NOERR) THEN
-        print *,'Guide: probleme lecture niveaux pression'
-        CALL abort_gcm(modname,abort_message,1)
+        CALL abort_gcm(modname,'Guide: probleme lecture niveaux pression',1)
     ENDIF
     error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
Index: LMDZ5/branches/testing/libf/dyn3d/iniacademic.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/iniacademic.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/iniacademic.F90	(revision 2298)
@@ -5,5 +5,5 @@
 
   USE filtreg_mod, ONLY: inifilr
-  USE infotrac, ONLY : nqtot
+  USE infotrac
   USE control_mod, ONLY: day_step,planet_type
 #ifdef CPP_IOIPSL
@@ -262,8 +262,27 @@
               if (i == 2) q(:,:,i)=1.e-15
               if (i.gt.2) q(:,:,i)=0.
+
+              ! CRisi: init des isotopes
+              ! distill de Rayleigh très simplifiée
+              if (ok_isotopes) then
+                if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then          
+                   q(:,:,i)=q(:,:,iqpere(i))             &
+      &                  *tnat(iso_num(i))               &
+      &                  *(q(:,:,iqpere(i))/30.e-3)      &
+      &                  **(alpha_ideal(iso_num(i))-1)
+                endif                
+                if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
+                  q(:,:,i)=q(:,:,iqiso(iso_indnum(i),phase_num(i)))
+                endif
+              endif !if (ok_isotopes) then
+
            enddo
         else
            q(:,:,:)=0
         endif ! of if (planet_type=="earth")
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
+        endif !if (ok_iso_verif) then
 
         ! add random perturbation to temperature
Index: LMDZ5/branches/testing/libf/dyn3d/leapfrog.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/leapfrog.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/leapfrog.F	(revision 2298)
@@ -11,5 +11,5 @@
       use IOIPSL
 #endif
-      USE infotrac, ONLY: nqtot
+      USE infotrac, ONLY: nqtot,ok_iso_verif
       USE guide_mod, ONLY : guide_main
       USE write_field, ONLY: writefield
@@ -235,4 +235,7 @@
       jH_cur = jH_cur - int(jH_cur)
 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
+        endif !if (ok_iso_verif) then
 
 #ifdef CPP_IOIPSL
@@ -265,4 +268,8 @@
 !      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
 !      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
+        endif !if (ok_iso_verif) then
 
    2  CONTINUE ! Matsuno backward or leapfrog step begins here
@@ -305,4 +312,9 @@
       endif
 
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
+        endif !if (ok_iso_verif) then
+
 c-----------------------------------------------------------------------
 c   calcul des tendances dynamiques:
@@ -321,4 +333,9 @@
 c   calcul des tendances advection des traceurs (dont l'humidite)
 c   -------------------------------------------------------------
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,
+     &           'leapfrog 686: avant caladvtrac')
+        endif !if (ok_iso_verif) then
 
       IF( forward. OR . leapf )  THEN
@@ -327,4 +344,6 @@
      *        p, masse, dq,  teta,
      .        flxw, pk)
+          !write(*,*) 'caladvtrac 346'
+
          
          IF (offline) THEN
@@ -346,9 +365,17 @@
 c   ----------------------------------
 
-
-       CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+        if (ok_iso_verif) then
+           write(*,*) 'leapfrog 720' 
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
+        endif !if (ok_iso_verif) then
+        
+       CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
      $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
 !     $              finvmaold                                    )
 
+       if (ok_iso_verif) then
+          write(*,*) 'leapfrog 724'
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
+        endif !if (ok_iso_verif) then
 
 c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
@@ -437,9 +464,10 @@
 #endif
 ! #endif of #ifdef CPP_IOIPSL
+#ifdef CPP_PHYS
          CALL calfis( 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  )
-
+#endif
 c      ajout des tendances physiques:
 c      ------------------------------
@@ -515,4 +543,7 @@
         CALL massdair(p,masse)
 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
+        endif !if (ok_iso_verif) then
 
 c-----------------------------------------------------------------------
@@ -599,4 +630,8 @@
 c   preparation du pas d'integration suivant  ......
 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
+        endif !if (ok_iso_verif) then
+
       IF ( .NOT.purmats ) THEN
 c       ........................................................
@@ -656,4 +691,8 @@
             ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
+        endif !if (ok_iso_verif) then
+
 c-----------------------------------------------------------------------
 c   ecriture de la bande histoire:
@@ -734,4 +773,8 @@
       ELSE ! of IF (.not.purmats)
 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
+        endif !if (ok_iso_verif) then
+
 c       ........................................................
 c       ..............       schema  matsuno        ...............
@@ -756,4 +799,8 @@
 
             ELSE ! of IF(forward) i.e. backward step
+ 
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
+        endif !if (ok_iso_verif) then  
 
               IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
Index: LMDZ5/branches/testing/libf/dyn3d/qminimum.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/qminimum.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/qminimum.F	(revision 2298)
@@ -2,6 +2,7 @@
 ! $Header$
 !
-      SUBROUTINE qminimum( q,nq,deltap )
+      SUBROUTINE qminimum( q,nqtot,deltap )
 
+      USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
       IMPLICIT none
 c
@@ -13,6 +14,6 @@
 #include "comvert.h"
 c
-      INTEGER nq
-      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+      INTEGER nqtot
+      REAL q(ip1jmp1,llm,nqtot), deltap(ip1jmp1,llm)
 c
       INTEGER iq_vap, iq_liq
@@ -30,4 +31,7 @@
       INTEGER i, k, iq
       REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+
+      real zx_defau_diag(ip1jmp1,llm,2) 
+      real q_follow(ip1jmp1,llm,2)
 c
       REAL SSUM
@@ -36,4 +40,8 @@
       SAVE imprim
       DATA imprim /0/
+      !INTEGER ijb,ije
+      !INTEGER Index_pump(ij_end-ij_begin+1)
+      !INTEGER nb_pump
+      INTEGER ixt
 c
 c Quand l'eau liquide est trop petite (ou negative), on prend
@@ -41,7 +49,20 @@
 c (sans changer la temperature !)
 c
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'qminimum 52')   
+        endif !if (ok_iso_verif) then     
+
+      zx_defau_diag(:,:,:)=0.0
+      q_follow(:,:,1:2)=q(:,:,1:2)  
       DO 1000 k = 1, llm
         DO 1040 i = 1, ip1jmp1
           if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+
+              if (ok_isotopes) then
+                 zx_defau_diag(i,k,iq_liq)=AMAX1
+     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
+              endif !if (ok_isotopes) then
+
              q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
              q(i,k,iq_liq) = seuil_liq
@@ -59,4 +80,9 @@
         DO i = 1, ip1jmp1
           if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
+
+            if (ok_isotopes) then
+              zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+            endif !if (ok_isotopes) then
+
             q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
      &                     deltap(i,k) / deltap(i,k-1)
@@ -83,4 +109,83 @@
          ENDDO
       ENDIF
+
+      !write(*,*) 'qminimum 128'
+      if (ok_isotopes) then
+      ! CRisi: traiter de même les traceurs d'eau
+      ! Mais il faut les prendre à l'envers pour essayer de conserver la
+      ! masse.
+      ! 1) pompage dans le sol  
+      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+      ! rien ici et on croise les doigts pour que ça ne soit pas trop
+      ! génant
+      DO i = 1,ip1jmp1
+        if (zx_pump(i).gt.0.0) then
+          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
+        endif !if (zx_pump(i).gt.0.0) then
+      enddo !DO i = 1,ip1jmp1
+
+      ! 2) transfert de vap vers les couches plus hautes
+      !write(*,*) 'qminimum 139'
+      do k=2,llm
+        DO i = 1,ip1jmp1
+          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
+              ! on ajoute la vapeur en k              
+              do ixt=1,ntraciso
+               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
+     :              +zx_defau_diag(i,k,iq_vap)
+     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+                
+              ! et on la retranche en k-1
+               q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,iq_vap)
+     :              *deltap(i,k)/deltap(i,k-1)
+     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+
+              enddo !do ixt=1,niso
+              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
+     :               +zx_defau_diag(i,k,iq_vap)
+              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
+     :               -zx_defau_diag(i,k,iq_vap)
+     :              *deltap(i,k)/deltap(i,k-1)
+          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+        enddo !DO i = 1, ip1jmp1        
+       enddo !do k=2,llm
+
+        if (ok_iso_verif) then     
+           call check_isotopes_seq(q,ip1jmp1,'qminimum 168')
+        endif !if (ok_iso_verif) then
+        
+      
+        ! 3) transfert d'eau de la vapeur au liquide
+        !write(*,*) 'qminimum 164'
+        do k=1,llm
+        DO i = 1,ip1jmp1
+          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
+
+              ! on ajoute eau liquide en k en k              
+              do ixt=1,ntraciso
+               q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
+     :              +zx_defau_diag(i,k,iq_liq)
+     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
+              ! et on la retranche à la vapeur en k
+               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,iq_liq)
+     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
+              enddo !do ixt=1,niso
+              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
+     :               +zx_defau_diag(i,k,iq_liq)
+              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
+     :               -zx_defau_diag(i,k,iq_liq)
+          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+        enddo !DO i = 1, ip1jmp1
+       enddo !do k=2,llm  
+
+        if (ok_iso_verif) then
+           call check_isotopes_seq(q,ip1jmp1,'qminimum 197')
+        endif !if (ok_iso_verif) then
+
+      endif !if (ok_isotopes) then
+      !write(*,*) 'qminimum 188'
+      
 c
       RETURN
Index: LMDZ5/branches/testing/libf/dyn3d/vlsplt.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/vlsplt.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/vlsplt.F	(revision 2298)
@@ -3,5 +3,6 @@
 c
 
-      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt)
+      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
+      USE infotrac, ONLY: nqtot,nqdesc,iqfils
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -32,7 +33,8 @@
 c      REAL masse(iip1,jjp1,llm),pente_max
       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
-      REAL q(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot)
 c      REAL q(iip1,jjp1,llm)
       REAL w(ip1jmp1,llm),pdt
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -42,9 +44,9 @@
       INTEGER ijlqmin,iqmin,jqmin,lqmin
 c
-      REAL zm(ip1jmp1,llm),newmasse
+      REAL zm(ip1jmp1,llm,nqtot),newmasse
       REAL mu(ip1jmp1,llm)
       REAL mv(ip1jm,llm)
       REAL mw(ip1jmp1,llm+1)
-      REAL zq(ip1jmp1,llm),zz
+      REAL zq(ip1jmp1,llm,nqtot),zz
       REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
       REAL second,temps0,temps1,temps2,temps3
@@ -55,4 +57,5 @@
       SAVE temps1,temps2,temps3
       INTEGER iminn,imaxx
+      INTEGER ifils,iq2 ! CRisi
 
       REAL qmin,qmax
@@ -79,27 +82,35 @@
          mw(ij,llm+1)=0.
       ENDDO
-      
-      CALL SCOPY(ijp1llm,q,1,zq,1)
-      CALL SCOPY(ijp1llm,masse,1,zm,1)
+           
+      CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
+      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
+        
+      if (nqdesc(iq).gt.0) then  
+        do ifils=1,nqdesc(iq)
+          iq2=iqfils(ifils,iq)
+          CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
+        enddo  
+      endif !if (nqfils(iq).gt.0) then
 
 cprint*,'Entree vlx1'
 c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
-      call vlx(zq,pente_max,zm,mu)
+      call vlx(zq,pente_max,zm,mu,iq)
 cprint*,'Sortie vlx1'
 c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
 
 c print*,'Entree vly1'
-      call vly(zq,pente_max,zm,mv)
+
+      call vly(zq,pente_max,zm,mv,iq)
 c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
 cprint*,'Sortie vly1'
-      call vlz(zq,pente_max,zm,mw)
+      call vlz(zq,pente_max,zm,mw,iq)
 c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
 
 
-      call vly(zq,pente_max,zm,mv)
+      call vly(zq,pente_max,zm,mv,iq)
 c	call minmaxq(zq,qmin,qmax,'apres vly     ')
 
 
-      call vlx(zq,pente_max,zm,mu)
+      call vlx(zq,pente_max,zm,mu,iq)
 c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
 	
@@ -107,14 +118,29 @@
       DO l=1,llm
          DO ij=1,ip1jmp1
-           q(ij,l)=zq(ij,l)
+           q(ij,l,iq)=zq(ij,l,iq)
          ENDDO
          DO ij=1,ip1jm+1,iip1
-            q(ij+iim,l)=q(ij,l)
-         ENDDO
-      ENDDO
+            q(ij+iim,l,iq)=q(ij,l,iq)
+         ENDDO
+      ENDDO
+      ! CRisi: aussi pour les fils
+      if (nqdesc(iq).gt.0) then
+      do ifils=1,nqdesc(iq)
+        iq2=iqfils(ifils,iq)
+        DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l,iq2)=zq(ij,l,iq2)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l,iq2)=q(ij,l,iq2)
+         ENDDO
+        ENDDO
+      enddo !do ifils=1,nqdesc(iq)    
+      endif ! if (nqdesc(iq).gt.0) then    
 
       RETURN
       END
-      SUBROUTINE vlx(q,pente_max,masse,u_m)
+      RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
 
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -139,8 +165,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse(ip1jmp1,llm,nqtot),pente_max
       REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
-      REAL q(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot)
       REAL w(ip1jmp1,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -155,4 +182,8 @@
       REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
       REAL u_mq(ip1jmp1,llm)
+
+      ! CRisi
+      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
+      INTEGER ifils,iq2 ! CRisi
 
       Logical extremum,first,testcpu
@@ -188,7 +219,7 @@
          DO l = 1, llm
             DO ij=iip2,ip1jm-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
 c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
-c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
             ENDDO
             DO ij=iip1+iip1,ip1jm,iip1
@@ -243,5 +274,5 @@
          DO l = 1, llm
             DO ij=iip2,ip1jm-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
             ENDDO
             DO ij=iip1+iip1,ip1jm,iip1
@@ -285,11 +316,11 @@
       DO l=1,llm
        DO ij=iip2,ip1jm-1
-          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
-     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
      ,                     u_m(ij,l))
           zdum(ij,l)=0.5*zdum(ij,l)
           u_mq(ij,l)=cvmgp(
-     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
-     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
      ,                u_m(ij,l))
           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
@@ -303,11 +334,12 @@
       DO l=1,llm
        DO ij=iip2,ip1jm-1
-c	print*,'masse(',ij,')=',masse(ij,l)
+c	print*,'masse(',ij,')=',masse(ij,l,iq)
           IF (u_m(ij,l).gt.0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
           ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
+     &           -0.5*zdum(ij,l)*dxq(ij+1,l))
           ENDIF
        ENDDO
@@ -379,7 +411,8 @@
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m-masse(ijq,l)
+                     do while(zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
+     &                          *masse(ijq,l,iq)
+                        zu_m=zu_m-masse(ijq,l,iq)
                         i=mod(i-2+iim,iim)+1
                         ijq=(j-1)*iip1+i
@@ -387,18 +420,20 @@
 c   ajout de la maille non completement advectee
                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
-     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+     &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
+     &                  *dxq(ijq,l))
                   ELSE
                      ijq=ij+1
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(-zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m+masse(ijq,l)
+                     do while(-zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
+     &                          *masse(ijq,l,iq)
+                        zu_m=zu_m+masse(ijq,l,iq)
                         i=mod(i,iim)+1
                         ijq=(j-1)*iip1+i
                      ENDDO
 c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
-     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
+     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ENDIF
                ENDDO
@@ -417,4 +452,26 @@
       ENDDO
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlsplt 326: iq,nqfils(iq)=',iq,nqfils(iq) 
+      
+      if (nqdesc(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+         DO l=1,llm
+          DO ij=iip2,ip1jm
+           ! On a besoin de q et masse seulement entre iip2 et ip1jm 
+           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+          enddo   
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi
+
 
 c   calcul des tENDances
@@ -422,16 +479,34 @@
       DO l=1,llm
          DO ij=iip2+1,ip1jm
-            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+
+            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
      &      u_mq(ij-1,l)-u_mq(ij,l))
      &      /new_m
-            masse(ij,l)=new_m
+            masse(ij,l,iq)=new_m
          ENDDO
 c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
          DO ij=iip1+iip1,ip1jm,iip1
-            q(ij-iim,l)=q(ij,l)
-            masse(ij-iim,l)=masse(ij,l)
-         ENDDO
-      ENDDO
+            q(ij-iim,l,iq)=q(ij,l,iq)
+            masse(ij-iim,l,iq)=masse(ij,l,iq)
+         ENDDO
+      ENDDO
+
+      ! retablir les fils en rapport de melange par rapport a l'air:
+      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio 
+      ! puis on boucle en longitude
+      if (nqdesc(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+         DO l=1,llm
+          DO ij=iip2+1,ip1jm
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+          DO ij=iip1+iip1,ip1jm,iip1
+             q(ij-iim,l,iq2)=q(ij,l,iq2)
+          enddo ! DO ij=ijb+iip1-1,ije,iip1
+         enddo !DO l=1,llm
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
@@ -440,5 +515,6 @@
       RETURN
       END
-      SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
+      RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -464,7 +540,8 @@
 c   Arguments:
 c   ----------
-      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse(ip1jmp1,llm,nqtot),pente_max
       REAL masse_adv_v( ip1jm,llm)
-      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot), dq( ip1jmp1,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -491,4 +568,8 @@
       SAVE sinlon,coslon,sinlondlon,coslondlon
       SAVE airej2,airejjm
+
+      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
+
 c
 c
@@ -497,4 +578,6 @@
       DATA first,testcpu/.true.,.false./
       DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      !write(*,*) 'vly 578: entree, iq=',iq
 
       IF(first) THEN
@@ -529,6 +612,6 @@
 
       DO i = 1, iim
-      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
-      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
       ENDDO
       qpns   = SSUM( iim,  airescb ,1 ) / airej2
@@ -538,5 +621,5 @@
 
       DO ij=1,ip1jm
-         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
          adyqv(ij)=abs(dyqv(ij))
       ENDDO
@@ -553,6 +636,6 @@
 
       DO ij=1,iip1
-         dyq(ij,l)=qpns-q(ij+iip1,l)
-         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+         dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
       ENDDO
 
@@ -675,12 +758,15 @@
       ENDDO
 
+      !write(*,*) 'vly 756'
       DO l=1,llm
        DO ij=1,ip1jm
           IF(masse_adv_v(ij,l).gt.0) THEN
-              qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
-     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+              qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)
+     ,                   /masse(ij+iip1,l,iq))
           ELSE
-              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+              qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)
+     ,                   /masse(ij,l,iq))
           ENDIF
           qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
@@ -688,12 +774,34 @@
       ENDDO
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq) 
+   
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+         DO l=1,llm
+         DO ij=1,ip1jmp1
+           ! attention, chaque fils doit avoir son masseq, sinon, le 1er
+           ! fils ecrase le masseq de ses freres.
+           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
+          enddo   
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vly(Ratio,pente_max,masseq,qbyv,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
 
       DO l=1,llm
          DO ij=iip2,ip1jm
-            newmasse=masse(ij,l)
+            newmasse=masse(ij,l,iq)
      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
-     &         /newmasse
-            masse(ij,l)=newmasse
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
+     &         -qbyv(ij-iip1,l))/newmasse
+            masse(ij,l,iq)=newmasse
          ENDDO
 c.-. ancienne version
@@ -703,12 +811,12 @@
          convpn=SSUM(iim,qbyv(1,l),1)
          convmpn=ssum(iim,masse_adv_v(1,l),1)
-         massepn=ssum(iim,masse(1,l),1)
+         massepn=ssum(iim,masse(1,l,iq),1)
          qpn=0.
          do ij=1,iim
-            qpn=qpn+masse(ij,l)*q(ij,l)
+            qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
          enddo
          qpn=(qpn+convpn)/(massepn+convmpn)
          do ij=1,iip1
-            q(ij,l)=qpn
+            q(ij,l,iq)=qpn
          enddo
 
@@ -718,12 +826,12 @@
          convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
          convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-         masseps=ssum(iim, masse(ip1jm+1,l),1)
+         masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
          qps=0.
          do ij = ip1jm+1,ip1jmp1-1
-            qps=qps+masse(ij,l)*q(ij,l)
+            qps=qps+masse(ij,l,iq)*q(ij,l,iq)
          enddo
          qps=(qps+convps)/(masseps+convmps)
          do ij=ip1jm+1,ip1jmp1
-            q(ij,l)=qps
+            q(ij,l,iq)=qps
          enddo
 
@@ -739,5 +847,5 @@
 c        DO ij = 1,iip1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
@@ -749,12 +857,27 @@
 c        DO ij = ip1jm+1,ip1jmp1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c._. fin nouvelle version
       ENDDO
+  
+! retablir les fils en rapport de melange par rapport a l'air:
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+         DO l=1,llm
+          DO ij=1,ip1jmp1
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+      !write(*,*) 'vly 853: sortie'
 
       RETURN
       END
-      SUBROUTINE vlz(q,pente_max,masse,w)
+      RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi 
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -779,7 +902,8 @@
 c   Arguments:
 c   ----------
-      REAL masse(ip1jmp1,llm),pente_max
-      REAL q(ip1jmp1,llm)
+      REAL masse(ip1jmp1,llm,nqtot),pente_max
+      REAL q(ip1jmp1,llm,nqtot)
       REAL w(ip1jmp1,llm+1)
+      INTEGER iq
 c
 c      Local 
@@ -792,4 +916,7 @@
       REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
       REAL sigw
+
+      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
 
       LOGICAL testcpu
@@ -805,4 +932,6 @@
 c    On oriente tout dans le sens de la pression c'est a dire dans le
 c    sens de W
+
+      !write(*,*) 'vlz 923: entree'
 
 #ifdef BIDON
@@ -813,5 +942,5 @@
       DO l=2,llm
          DO ij=1,ip1jmp1
-            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
             adzqw(ij,l)=abs(dzqw(ij,l))
          ENDDO
@@ -835,4 +964,5 @@
       ENDDO
 
+      !write(*,*) 'vlz 954'
       DO ij=1,ip1jmp1
          dzq(ij,1)=0.
@@ -851,12 +981,14 @@
 c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
 
+       !write(*,*) 'vlz 969'
        DO l = 1,llm-1
          do  ij = 1,ip1jmp1
           IF(w(ij,l+1).gt.0.) THEN
-             sigw=w(ij,l+1)/masse(ij,l+1)
-             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+             sigw=w(ij,l+1)/masse(ij,l+1,iq)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq)
+     &           +0.5*(1.-sigw)*dzq(ij,l+1))
           ELSE
-             sigw=w(ij,l+1)/masse(ij,l)
-             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+             sigw=w(ij,l+1)/masse(ij,l,iq)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
           ENDIF
          ENDDO
@@ -868,13 +1000,46 @@
        ENDDO
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+         DO l=1,llm
+          DO ij=1,ip1jmp1
+           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)        
+          enddo   
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+        
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)         
+         call vlz(Ratio,pente_max,masseq,wq,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi  
+
       DO l=1,llm
          DO ij=1,ip1jmp1
-            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+            newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l))
      &         /newmasse
-            masse(ij,l)=newmasse
-         ENDDO
-      ENDDO
-
+            masse(ij,l,iq)=newmasse
+         ENDDO
+      ENDDO
+
+! retablir les fils en rapport de melange par rapport a l'air:
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+         DO l=1,llm
+          DO ij=1,ip1jmp1
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+      !write(*,*) 'vlsplt 1032'
 
       RETURN
Index: LMDZ5/branches/testing/libf/dyn3d/vlspltqs.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d/vlspltqs.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d/vlspltqs.F	(revision 2298)
@@ -3,5 +3,6 @@
 c
        SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
-     ,                                  p,pk,teta                 )
+     ,                                  p,pk,teta,iq             )
+       USE infotrac, ONLY: nqtot,nqdesc,iqfils
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
@@ -35,7 +36,8 @@
       REAL masse(ip1jmp1,llm),pente_max
       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
-      REAL q(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot)
       REAL w(ip1jmp1,llm),pdt
       REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -43,11 +45,12 @@
 c
       INTEGER i,ij,l,j,ii
+      INTEGER ifils,iq2 ! CRisi
 c
       REAL qsat(ip1jmp1,llm)
-      REAL zm(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm,nqtot)
       REAL mu(ip1jmp1,llm)
       REAL mv(ip1jm,llm)
       REAL mw(ip1jmp1,llm+1)
-      REAL zq(ip1jmp1,llm)
+      REAL zq(ip1jmp1,llm,nqtot)
       REAL temps1,temps2,temps3
       REAL zzpbar, zzw
@@ -116,31 +119,33 @@
       ENDDO
 
-      CALL SCOPY(ijp1llm,q,1,zq,1)
-      CALL SCOPY(ijp1llm,masse,1,zm,1)
+      CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
+      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
+      if (nqdesc(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+        iq2=iqfils(ifils,iq)
+        CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
+       enddo  
+      endif !if (nqfils(iq).gt.0) then
 
 c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
-      call vlxqs(zq,pente_max,zm,mu,qsat)
-
+      call vlxqs(zq,pente_max,zm,mu,qsat,iq)
 
 c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
 
-      call vlyqs(zq,pente_max,zm,mv,qsat)
-
+      call vlyqs(zq,pente_max,zm,mv,qsat,iq)
 
 c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
 
-      call vlz(zq,pente_max,zm,mw)
-
+      call vlz(zq,pente_max,zm,mw,iq)
 
 c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
 c     call minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
 
-      call vlyqs(zq,pente_max,zm,mv,qsat)
-
+      call vlyqs(zq,pente_max,zm,mv,qsat,iq)
 
 c     call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
 c     call minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
 
-      call vlxqs(zq,pente_max,zm,mu,qsat)
+      call vlxqs(zq,pente_max,zm,mu,qsat,iq)
 
 c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
@@ -150,14 +155,31 @@
       DO l=1,llm
          DO ij=1,ip1jmp1
-           q(ij,l)=zq(ij,l)
+           q(ij,l,iq)=zq(ij,l,iq)
          ENDDO
          DO ij=1,ip1jm+1,iip1
-            q(ij+iim,l)=q(ij,l)
-         ENDDO
-      ENDDO
+            q(ij+iim,l,iq)=q(ij,l,iq)
+         ENDDO
+      ENDDO
+      ! CRisi: aussi pour les fils
+      if (nqdesc(iq).gt.0) then
+      do ifils=1,nqdesc(iq)
+        iq2=iqfils(ifils,iq)
+        DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l,iq2)=zq(ij,l,iq2)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l,iq2)=q(ij,l,iq2)
+         ENDDO
+        ENDDO
+      enddo !do ifils=1,nqdesc(iq)  
+      endif ! if (nqfils(iq).gt.0) then
+      !write(*,*) 'vlspltqs 183: fin de la routine'
 
       RETURN
       END
-      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat)
+      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
+
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -179,8 +201,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse(ip1jmp1,llm,nqtot),pente_max
       REAL u_m( ip1jmp1,llm )
-      REAL q(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot)
       REAL qsat(ip1jmp1,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -195,4 +218,8 @@
       REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
       REAL u_mq(ip1jmp1,llm)
+
+      ! CRisi
+      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
+      INTEGER ifils,iq2 ! CRisi
 
       Logical first,testcpu
@@ -227,7 +254,7 @@
          DO l = 1, llm
             DO ij=iip2,ip1jm-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
 c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
-c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
             ENDDO
             DO ij=iip1+iip1,ip1jm,iip1
@@ -281,5 +308,5 @@
          DO l = 1, llm
             DO ij=iip2,ip1jm-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
             ENDDO
             DO ij=iip1+iip1,ip1jm,iip1
@@ -323,11 +350,11 @@
       DO l=1,llm
        DO ij=iip2,ip1jm-1
-          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
-     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
      ,                     u_m(ij,l))
           zdum(ij,l)=0.5*zdum(ij,l)
           u_mq(ij,l)=cvmgp(
-     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
-     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
      ,                u_m(ij,l))
           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
@@ -341,11 +368,11 @@
        DO ij=iip2,ip1jm-1
           IF (u_m(ij,l).gt.0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
              u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
           ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
              u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
           ENDIF
        ENDDO
@@ -416,7 +443,8 @@
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m-masse(ijq,l)
+                     do while(zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
+     &                          *masse(ijq,l,iq)
+                        zu_m=zu_m-masse(ijq,l,iq)
                         i=mod(i-2+iim,iim)+1
                         ijq=(j-1)*iip1+i
@@ -424,18 +452,20 @@
 c   ajout de la maille non completement advectee
                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
-     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+     &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
+     &                  *dxq(ijq,l))
                   ELSE
                      ijq=ij+1
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(-zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m+masse(ijq,l)
+                     do while(-zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
+     &                          *masse(ijq,l,iq)
+                        zu_m=zu_m+masse(ijq,l,iq)
                         i=mod(i,iim)+1
                         ijq=(j-1)*iip1+i
                      ENDDO
 c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
-     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
+     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ENDIF
                ENDDO
@@ -454,4 +484,25 @@
       ENDDO
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlspltqs 326: iq,nqfils(iq)=',iq,nqfils(iq) 
+      
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+         DO l=1,llm
+          DO ij=iip2,ip1jm
+           ! On a besoin de q et masse seulement entre iip2 et ip1jm 
+           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+          enddo   
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi
 
 c   calcul des tendances
@@ -459,16 +510,33 @@
       DO l=1,llm
          DO ij=iip2+1,ip1jm
-            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+
+            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
      &      u_mq(ij-1,l)-u_mq(ij,l))
      &      /new_m
-            masse(ij,l)=new_m
+            masse(ij,l,iq)=new_m
          ENDDO
 c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
          DO ij=iip1+iip1,ip1jm,iip1
-            q(ij-iim,l)=q(ij,l)
-            masse(ij-iim,l)=masse(ij,l)
-         ENDDO
-      ENDDO
+            q(ij-iim,l,iq)=q(ij,l,iq)
+            masse(ij-iim,l,iq)=masse(ij,l,iq)
+         ENDDO
+      ENDDO
+
+      ! retablir les fils en rapport de melange par rapport a l'air:
+      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio 
+      ! puis on boucle en longitude
+      if (nqdesc(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+         DO l=1,llm
+          DO ij=iip2+1,ip1jm
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+          DO ij=iip1+iip1,ip1jm,iip1
+             q(ij-iim,l,iq2)=q(ij,l,iq2)
+          enddo ! DO ij=ijb+iip1-1,ije,iip1
+         enddo !DO l=1,llm
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
 
 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
@@ -478,5 +546,6 @@
       RETURN
       END
-      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat)
+      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -502,8 +571,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse(ip1jmp1,llm,nqtot),pente_max
       REAL masse_adv_v( ip1jm,llm)
-      REAL q(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot)
       REAL qsat(ip1jmp1,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -529,4 +599,7 @@
       SAVE sinlon,coslon,sinlondlon,coslondlon
       SAVE airej2,airejjm
+
+      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
 c
 c
@@ -567,6 +640,6 @@
 
       DO i = 1, iim
-      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
-      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
       ENDDO
       qpns   = SSUM( iim,  airescb ,1 ) / airej2
@@ -576,5 +649,5 @@
 
       DO ij=1,ip1jm
-         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
          adyqv(ij)=abs(dyqv(ij))
       ENDDO
@@ -591,6 +664,6 @@
 
       DO ij=1,iip1
-         dyq(ij,l)=qpns-q(ij+iip1,l)
-         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+         dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
       ENDDO
 
@@ -710,9 +783,10 @@
        DO ij=1,ip1jm
          IF( masse_adv_v(ij,l).GT.0. ) THEN
-           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
-     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
+     ,      /masse(ij+iip1,l,iq)))
          ELSE
-              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
          ENDIF
           qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
@@ -721,11 +795,33 @@
 
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq) 
+   
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+         DO l=1,llm
+         DO ij=1,ip1jmp1
+           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
+          enddo   
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
+         call vly(Ratio,pente_max,masseq,qbyv,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+
       DO l=1,llm
          DO ij=iip2,ip1jm
-            newmasse=masse(ij,l)
+            newmasse=masse(ij,l,iq)
      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
-     &         /newmasse
-            masse(ij,l)=newmasse
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
+     &         -qbyv(ij-iip1,l))/newmasse
+            masse(ij,l,iq)=newmasse
          ENDDO
 c.-. ancienne version
@@ -733,16 +829,16 @@
          convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
          DO ij = 1,iip1
-            newmasse=masse(ij,l)+convmpn*aire(ij)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+            newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
      &               newmasse
-            masse(ij,l)=newmasse
+            masse(ij,l,iq)=newmasse
          ENDDO
          convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
          convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
          DO ij = ip1jm+1,ip1jmp1
-            newmasse=masse(ij,l)+convmps*aire(ij)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+            newmasse=masse(ij,l,iq)+convmps*aire(ij)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
      &               newmasse
-            masse(ij,l)=newmasse
+            masse(ij,l,iq)=newmasse
          ENDDO
 c.-. fin ancienne version
@@ -757,5 +853,5 @@
 c        DO ij = 1,iip1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
@@ -767,9 +863,24 @@
 c        DO ij = ip1jm+1,ip1jmp1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c._. fin nouvelle version
       ENDDO
 
+      !write(*,*) 'vly 866'
+
+! retablir les fils en rapport de melange par rapport a l'air:
+      if (nqdesc(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+         DO l=1,llm
+          DO ij=1,ip1jmp1
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+      !write(*,*) 'vly 879'
+
       RETURN
       END
Index: LMDZ5/branches/testing/libf/dyn3d_common/coefpoly_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/coefpoly_m.F90	(revision 2274)
+++ 	(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: LMDZ5/branches/testing/libf/dyn3d_common/description.h
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/description.h	(revision 2274)
+++ 	(revision )
@@ -1,5 +1,0 @@
-!
-! $Header$
-!
-      character (len=120) :: descript
-      common /titre/descript
Index: LMDZ5/branches/testing/libf/dyn3d_common/diagedyn.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/diagedyn.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d_common/diagedyn.F	(revision 2298)
@@ -53,4 +53,6 @@
 c======================================================================
  
+      USE control_mod, ONLY : planet_type
+      
       IMPLICIT NONE
 C
@@ -60,8 +62,20 @@
 #include "iniprint.h"
 
-#ifdef CPP_EARTH
-#include "../phylmd/YOMCST.h"
-#include "../phylmd/YOETHF.h"
-#endif
+!#ifdef CPP_EARTH
+!#include "../phylmd/YOMCST.h"
+!#include "../phylmd/YOETHF.h"
+!#endif
+! Ehouarn: for now set these parameters to what is in Earth physics...
+!          (cf ../phylmd/suphel.h)
+!          this should be generalized...
+      REAL,PARAMETER :: RCPD=
+     &               3.5*(1000.*(6.0221367E+23*1.380658E-23)/28.9644)
+      REAL,PARAMETER :: RCPV=
+     &               4.*(1000.*(6.0221367E+23*1.380658E-23)/18.0153)
+      REAL,PARAMETER :: RCS=RCPV
+      REAL,PARAMETER :: RCW=RCPV
+      REAL,PARAMETER :: RLSTT=2.8345E+6
+      REAL,PARAMETER :: RLVTT=2.5008E+6
+!
 C
       INTEGER imjmp1
@@ -140,5 +154,7 @@
 
 
-#ifdef CPP_EARTH
+!#ifdef CPP_EARTH
+      IF (planet_type=="earth") THEN
+      
 c======================================================================
 C     Compute Kinetic enrgy
@@ -314,7 +330,9 @@
       ec_pre (idiag)    = ec_tot
 C
-#else
-      write(lunout,*)'diagedyn: Needs Earth physics to function'
-#endif
+!#else
+      ELSE
+        write(lunout,*)'diagedyn: set to function with Earth parameters'
+      ENDIF ! of if (planet_type=="earth")
+!#endif
 ! #endif of #ifdef CPP_EARTH 
       RETURN 
Index: LMDZ5/branches/testing/libf/dyn3d_common/gr_dyn_fi.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/gr_dyn_fi.F	(revision 2274)
+++ 	(revision )
@@ -1,38 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
-c   traitement des poles
-      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
-      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
-
-c   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: LMDZ5/branches/testing/libf/dyn3d_common/gr_fi_dyn.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/gr_fi_dyn.F	(revision 2274)
+++ 	(revision )
@@ -1,40 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-      DO ifield=1,nfield
-c   traitement des poles
-         DO i=1,im
-            pdyn(i,1,ifield)=pfi(1,ifield)
-            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
-         ENDDO
-
-c   traitement des point normaux
-         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
-
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3d_common/infotrac.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/infotrac.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3d_common/infotrac.F90	(revision 2298)
@@ -12,4 +12,7 @@
   INTEGER, SAVE :: nbtr
 
+! CRisi: nb traceurs pères= directement advectés par l'air
+  INTEGER, SAVE :: nqperes
+
 ! Name variables
   CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
@@ -22,4 +25,11 @@
 !         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. 
   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
+
+! CRisi: tableaux de fils
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqfils
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqdesc ! nombres de fils + nombre de tous les petits fils sur toutes les générations
+  INTEGER, SAVE :: nqdesc_tot
+  INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE    :: iqfils
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iqpere
 
 ! conv_flg(it)=0 : convection desactivated for tracer number it 
@@ -30,4 +40,19 @@
   CHARACTER(len=4),SAVE :: type_trac
   CHARACTER(len=8),DIMENSION(:),ALLOCATABLE, SAVE :: solsym
+   
+    ! CRisi: cas particulier des isotopes
+    LOGICAL,SAVE :: ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso
+    INTEGER :: niso_possibles   
+    PARAMETER ( niso_possibles=5)
+    real, DIMENSION (niso_possibles),SAVE :: tnat,alpha_ideal
+    LOGICAL, DIMENSION(niso_possibles),SAVE ::  use_iso
+    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  iqiso ! donne indice iq en fn de (ixt,phase) 
+    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_num ! donne numéro iso entre 1 et niso_possibles en fn de nqtot
+    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_indnum ! donne numéro iso entre 1 et niso effectif en fn de nqtot
+    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  zone_num ! donne numéro de la zone de tracage en fn de nqtot
+    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  phase_num ! donne numéro de la zone de tracage en fn de nqtot
+    INTEGER, DIMENSION(niso_possibles), SAVE :: indnum_fn_num ! donne indice entre entre 1 et niso en fonction du numéro d isotope entre 1 et niso_possibles
+    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  index_trac ! numéro ixt en fn izone, indnum entre 1 et niso
+    INTEGER,SAVE :: niso,ntraceurs_zone,ntraciso
  
 CONTAINS
@@ -63,4 +88,5 @@
 
     CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
+    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_transp ! transporting fluid short name: CRisi
     CHARACTER(len=3), DIMENSION(30) :: descrq
     CHARACTER(len=1), DIMENSION(3)  :: txts
@@ -70,4 +96,8 @@
     INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
     INTEGER :: iq, new_iq, iiq, jq, ierr
+    INTEGER :: ifils,ipere,generation ! CRisi
+    LOGICAL :: continu,nouveau_traceurdef
+    INTEGER :: IOstatus ! gestion de la retrocompatibilite de traceur.def
+    CHARACTER(len=15) :: tchaine    
 
     character(len=*),parameter :: modname="infotrac_init"
@@ -134,4 +164,5 @@
           WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
           READ(90,*) nqtrue
+          write(lunout,*) 'nqtrue=',nqtrue
        ELSE 
           WRITE(lunout,*) trim(modname),': Problem in opening traceur.def'
@@ -143,16 +174,35 @@
           endif
        END IF
-       if ( planet_type=='earth') then
-         ! For Earth, water vapour & liquid tracers are not in the physics
-         nbtr=nqtrue-2
-       else
-         ! Other planets (for now); we have the same number of tracers
-         ! in the dynamics than in the physics
-         nbtr=nqtrue
-       endif
+!jyg<
+!!       if ( planet_type=='earth') then
+!!         ! For Earth, water vapour & liquid tracers are not in the physics
+!!         nbtr=nqtrue-2
+!!       else
+!!         ! Other planets (for now); we have the same number of tracers
+!!         ! in the dynamics than in the physics
+!!         nbtr=nqtrue
+!!       endif
+!>jyg
     ELSE ! type_trac=inca
+!jyg<
+       ! The traceur.def file is used to define the number "nqo" of water phases 
+       ! present in the simulation. Default : nqo = 2.
+       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
+       IF(ierr.EQ.0) THEN
+          WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
+          READ(90,*) nqo
+       ELSE 
+          WRITE(lunout,*) trim(modname),': Using default value for nqo'
+          nqo=2
+       ENDIF
+       IF (nqo /= 2 .OR. nqo /= 3 ) THEN
+          WRITE(lunout,*) trim(modname),': nqo=',nqo, ' is not allowded. Only 2 or 3 water phases allowed'
+          CALL abort_gcm('infotrac_init','Bad number of water phases',1)
+       END IF
        ! nbtr has been read from INCA by init_const_lmdz() in gcm.F 
-       nqtrue=nbtr+2
-    END IF
+       nqtrue=nbtr+nqo
+!!       nqtrue=nbtr+2
+    END IF   ! type_trac
+!>jyg
 
     IF ((planet_type=="earth").and.(nqtrue < 2)) THEN
@@ -161,18 +211,23 @@
     END IF
     
+!jyg<
 ! Transfert number of tracers to Reprobus
-    IF (type_trac == 'repr') THEN
-#ifdef REPROBUS
-       CALL Init_chem_rep_trac(nbtr)
-#endif
-    END IF
+!!    IF (type_trac == 'repr') THEN
+!!#ifdef REPROBUS
+!!       CALL Init_chem_rep_trac(nbtr)
+!!#endif
+!!    END IF
+!>jyg
        
 !
-! Allocate variables depending on nqtrue and nbtr
-!
-    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue))
-    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
-    conv_flg(:) = 1 ! convection activated for all tracers
-    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+! Allocate variables depending on nqtrue
+!
+    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue),tnom_transp(nqtrue))
+!
+!jyg<
+!!    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
+!!    conv_flg(:) = 1 ! convection activated for all tracers
+!!    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+!>jyg
 
 !-----------------------------------------------------------------------
@@ -206,7 +261,47 @@
           ! Continue to read tracer.def
           DO iq=1,nqtrue
-             READ(90,*) hadv(iq),vadv(iq),tnom_0(iq)
-          END DO
+
+             write(*,*) 'infotrac 237: iq=',iq
+             ! CRisi: ajout du nom du fluide transporteur
+             ! mais rester retro compatible
+             READ(90,'(I2,X,I2,X,A)',IOSTAT=IOstatus) hadv(iq),vadv(iq),tchaine
+             write(lunout,*) 'iq,hadv(iq),vadv(iq)=',iq,hadv(iq),vadv(iq)
+             write(lunout,*) 'tchaine=',trim(tchaine)
+             write(*,*) 'infotrac 238: IOstatus=',IOstatus
+             if (IOstatus.ne.0) then
+                CALL abort_gcm('infotrac_init','Pb dans la lecture de traceur.def',1)
+             endif
+             ! Y-a-t-il 1 ou 2 noms de traceurs? -> On regarde s'il y a un
+             ! espace ou pas au milieu de la chaine.
+             continu=1
+             nouveau_traceurdef=0
+             iiq=1
+             do while (continu)
+                if (tchaine(iiq:iiq).eq.' ') then
+                  nouveau_traceurdef=1
+                  continu=0
+                else if (iiq.lt.LEN_TRIM(tchaine)) then
+                  iiq=iiq+1
+                else
+                  continu=0      
+                endif
+             enddo
+             write(*,*) 'iiq,nouveau_traceurdef=',iiq,nouveau_traceurdef
+             if (nouveau_traceurdef) then
+                write(lunout,*) 'C''est la nouvelle version de traceur.def'
+                tnom_0(iq)=tchaine(1:iiq-1)
+                tnom_transp(iq)=tchaine(iiq+1:15)
+             else
+                write(lunout,*) 'C''est l''ancienne version de traceur.def'
+                write(lunout,*) 'On suppose que les traceurs sont tous d''air'
+                tnom_0(iq)=tchaine
+                tnom_transp(iq) = 'air'
+             endif
+             write(lunout,*) 'tnom_0(iq)=<',trim(tnom_0(iq)),'>'
+             write(lunout,*) 'tnom_transp(iq)=<',trim(tnom_transp(iq)),'>'
+
+          END DO !DO iq=1,nqtrue
           CLOSE(90)  
+
        ELSE ! Without tracer.def, set default values 
          if (planet_type=="earth") then
@@ -215,34 +310,66 @@
           vadv(1) = 14
           tnom_0(1) = 'H2Ov'
+          tnom_transp(1) = 'air'
           hadv(2) = 10
           vadv(2) = 10
           tnom_0(2) = 'H2Ol'
+          tnom_transp(2) = 'air'
           hadv(3) = 10
           vadv(3) = 10
           tnom_0(3) = 'RN'
+          tnom_transp(3) = 'air'
           hadv(4) = 10
           vadv(4) = 10
           tnom_0(4) = 'PB'
+          tnom_transp(4) = 'air'
          else ! default for other planets
           hadv(1) = 10
           vadv(1) = 10
           tnom_0(1) = 'dummy'
+          tnom_transp(1) = 'dummy'
          endif ! of if (planet_type=="earth")
        END IF
-
-!CR: nombre de traceurs de l eau
-       if (tnom_0(3) == 'H2Oi') then
-          nqo=3
-       else
-          nqo=2
-       endif
        
        WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
        WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
        DO iq=1,nqtrue
-          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
+          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq),tnom_transp(iq)
        END DO
 
-    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
+       if ( planet_type=='earth') then
+         !CR: nombre de traceurs de l eau
+         if (tnom_0(3) == 'H2Oi') then
+            nqo=3
+         else
+            nqo=2
+         endif
+         ! For Earth, water vapour & liquid tracers are not in the physics
+         nbtr=nqtrue-nqo
+       else
+         ! Other planets (for now); we have the same number of tracers
+         ! in the dynamics than in the physics
+         nbtr=nqtrue
+       endif
+
+    ENDIF  ! (type_trac == 'lmdz' .OR. type_trac == 'repr')
+!jyg<
+!
+! Transfert number of tracers to Reprobus
+    IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+       CALL Init_chem_rep_trac(nbtr)
+#endif
+    END IF
+!
+! Allocate variables depending on nbtr
+!
+    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
+    conv_flg(:) = 1 ! convection activated for all tracers
+    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+!
+!!    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
+!
+    IF (type_trac == 'inca') THEN   ! config_inca='aero' ou 'chem'
+!>jyg
 ! le module de chimie fournit les noms des traceurs
 ! et les schemas d'advection associes.
@@ -258,11 +385,17 @@
        tnom_0(1)='H2Ov'
        tnom_0(2)='H2Ol'
-
-       DO iq =3,nqtrue
-          tnom_0(iq)=solsym(iq-2)
+       IF (nqo == 3) tnom_0(3)='H2Oi'     !! jyg
+
+!jyg<
+       DO iq = nqo+1, nqtrue
+          tnom_0(iq)=solsym(iq-nqo)
        END DO
-       nqo = 2
-
-    END IF ! type_trac
+!!       DO iq =3,nqtrue
+!!          tnom_0(iq)=solsym(iq-2)
+!!       END DO
+!!       nqo = 2
+!>jyg
+
+    END IF ! (type_trac == 'inca')
 
 !-----------------------------------------------------------------------
@@ -390,11 +523,301 @@
     END DO
 
+
+! CRisi: quels sont les traceurs fils et les traceurs pères.
+! initialiser tous les tableaux d'indices liés aux traceurs familiaux
+! + vérifier que tous les pères sont écrits en premières positions
+    ALLOCATE(nqfils(nqtot),nqdesc(nqtot))    
+    ALLOCATE(iqfils(nqtot,nqtot))   
+    ALLOCATE(iqpere(nqtot))
+    nqperes=0
+    nqfils(:)=0
+    nqdesc(:)=0
+    iqfils(:,:)=0
+    iqpere(:)=0
+    nqdesc_tot=0    
+    DO iq=1,nqtot
+      if (tnom_transp(iq) == 'air') then
+        ! ceci est un traceur père
+        WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un pere'
+        nqperes=nqperes+1
+        iqpere(iq)=0
+      else !if (tnom_transp(iq) == 'air') then
+        ! ceci est un fils. Qui est son père?
+        WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un fils'
+        continu=.true.
+        ipere=1
+        do while (continu)           
+          if (tnom_transp(iq) == tnom_0(ipere)) then
+            ! Son père est ipere
+            WRITE(lunout,*) 'Le traceur',iq,'appele ', &
+      &          trim(tnom_0(iq)),' est le fils de ',ipere,'appele ',trim(tnom_0(ipere))
+            nqfils(ipere)=nqfils(ipere)+1  
+            iqfils(nqfils(ipere),ipere)=iq
+            iqpere(iq)=ipere         
+            continu=.false.
+          else !if (tnom_transp(iq) == tnom_0(ipere)) then
+            ipere=ipere+1 
+            if (ipere.gt.nqtot) then
+                WRITE(lunout,*) 'Le traceur',iq,'appele ', &
+      &          trim(tnom_0(iq)),', est orpelin.'
+                CALL abort_gcm('infotrac_init','Un traceur est orphelin',1)
+            endif !if (ipere.gt.nqtot) then
+          endif !if (tnom_transp(iq) == tnom_0(ipere)) then
+        enddo !do while (continu)
+      endif !if (tnom_transp(iq) == 'air') then
+    enddo !DO iq=1,nqtot
+    WRITE(lunout,*) 'infotrac: nqperes=',nqperes    
+    WRITE(lunout,*) 'nqfils=',nqfils
+    WRITE(lunout,*) 'iqpere=',iqpere
+    WRITE(lunout,*) 'iqfils=',iqfils
+
+! Calculer le nombre de descendants à partir de iqfils et de nbfils
+    DO iq=1,nqtot    
+      generation=0
+      continu=.true.
+      ifils=iq
+      do while (continu)
+        ipere=iqpere(ifils)
+        if (ipere.gt.0) then
+         nqdesc(ipere)=nqdesc(ipere)+1   
+         nqdesc_tot=nqdesc_tot+1      
+         iqfils(nqdesc(ipere),ipere)=iq
+         ifils=ipere
+         generation=generation+1
+        else !if (ipere.gt.0) then
+         continu=.false.
+        endif !if (ipere.gt.0) then
+      enddo !do while (continu)    
+      WRITE(lunout,*) 'Le traceur ',iq,', appele ',trim(tnom_0(iq)),' est un traceur de generation: ',generation
+    enddo !DO iq=1,nqtot
+    WRITE(lunout,*) 'infotrac: nqdesc=',nqdesc
+    WRITE(lunout,*) 'iqfils=',iqfils
+    WRITE(lunout,*) 'nqdesc_tot=',nqdesc_tot
+
+! Interdire autres schémas que 10 pour les traceurs fils, et autres schémas
+! que 10 et 14 si des pères ont des fils
+    do iq=1,nqtot
+      if (iqpere(iq).gt.0) then
+        ! ce traceur a un père qui n'est pas l'air
+        ! Seul le schéma 10 est autorisé
+        if (iadv(iq)/=10) then
+           WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for sons'
+          CALL abort_gcm('infotrac_init','Sons should be advected by scheme 10',1)
+        endif
+        ! Le traceur père ne peut être advecté que par schéma 10 ou 14:
+        IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
+          WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for fathers'
+          CALL abort_gcm('infotrac_init','Fathers should be advected by scheme 10 ou 14',1)
+        endif !IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
+     endif !if (iqpere(iq).gt.0) the
+    enddo !do iq=1,nqtot
+
+
+! detecter quels sont les traceurs isotopiques parmi des traceurs
+    call infotrac_isoinit(tnom_0,nqtrue)
+        
 !-----------------------------------------------------------------------
 ! Finalize :
 !
-    DEALLOCATE(tnom_0, hadv, vadv)
+    DEALLOCATE(tnom_0, hadv, vadv,tnom_transp)
 
 
   END SUBROUTINE infotrac_init
 
+  SUBROUTINE infotrac_isoinit(tnom_0,nqtrue)
+
+#ifdef CPP_IOIPSL
+  use IOIPSL
+#else
+  ! if not using IOIPSL, we still need to use (a local version of) getin
+  use ioipsl_getincom
+#endif
+  implicit none
+ 
+    ! inputs
+    INTEGER nqtrue
+    CHARACTER(len=15) tnom_0(nqtrue)
+    
+    ! locals    
+    CHARACTER(len=3), DIMENSION(niso_possibles) :: tnom_iso
+    INTEGER, ALLOCATABLE,DIMENSION(:,:) :: nb_iso,nb_traciso
+    INTEGER, ALLOCATABLE,DIMENSION(:) :: nb_isoind
+    INTEGER :: ntraceurs_zone_prec,iq,phase,ixt,iiso,izone
+    CHARACTER(len=19) :: tnom_trac
+    INCLUDE "iniprint.h"
+
+    tnom_iso=(/'eau','HDO','O18','O17','HTO'/)
+
+    ALLOCATE(nb_iso(niso_possibles,nqo))
+    ALLOCATE(nb_isoind(nqo))
+    ALLOCATE(nb_traciso(niso_possibles,nqo))
+    ALLOCATE(iso_num(nqtot))
+    ALLOCATE(iso_indnum(nqtot))
+    ALLOCATE(zone_num(nqtot))
+    ALLOCATE(phase_num(nqtot))
+     
+    iso_num(:)=0
+    iso_indnum(:)=0
+    zone_num(:)=0
+    phase_num(:)=0
+    indnum_fn_num(:)=0
+    use_iso(:)=.false.  
+    nb_iso(:,:)=0  
+    nb_isoind(:)=0     
+    nb_traciso(:,:)=0
+    niso=0
+    ntraceurs_zone=0  
+    ntraceurs_zone_prec=0
+    ntraciso=0
+
+    do iq=nqo+1,nqtot
+       write(lunout,*) 'infotrac 569: iq,tnom_0(iq)=',iq,tnom_0(iq)
+       do phase=1,nqo    
+        do ixt= 1,niso_possibles   
+         tnom_trac=trim(tnom_0(phase))//'_'
+         tnom_trac=trim(tnom_trac)//trim(tnom_iso(ixt))
+         write(*,*) 'phase,ixt,tnom_trac=',phase,ixt,tnom_trac      
+         IF (tnom_0(iq) == tnom_trac) then
+          write(lunout,*) 'Ce traceur est un isotope'
+          nb_iso(ixt,phase)=nb_iso(ixt,phase)+1   
+          nb_isoind(phase)=nb_isoind(phase)+1   
+          iso_num(iq)=ixt
+          iso_indnum(iq)=nb_isoind(phase)
+          indnum_fn_num(ixt)=iso_indnum(iq)
+          phase_num(iq)=phase
+          write(lunout,*) 'iso_num(iq)=',iso_num(iq)
+          write(lunout,*) 'iso_indnum(iq)=',iso_indnum(iq)
+          write(lunout,*) 'indnum_fn_num(ixt)=',indnum_fn_num(ixt)
+          write(lunout,*) 'phase_num(iq)=',phase_num(iq)
+          goto 20
+         else if (iqpere(iq).gt.0) then          
+          if (tnom_0(iqpere(iq)) == tnom_trac) then
+           write(lunout,*) 'Ce traceur est le fils d''un isotope'
+           ! c'est un traceur d'isotope
+           nb_traciso(ixt,phase)=nb_traciso(ixt,phase)+1
+           iso_num(iq)=ixt
+           iso_indnum(iq)=indnum_fn_num(ixt)
+           zone_num(iq)=nb_traciso(ixt,phase)
+           phase_num(iq)=phase
+           write(lunout,*) 'iso_num(iq)=',iso_num(iq)
+           write(lunout,*) 'phase_num(iq)=',phase_num(iq)
+           write(lunout,*) 'zone_num(iq)=',zone_num(iq)
+           goto 20
+          endif !if (tnom_0(iqpere(iq)) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
+         endif !IF (tnom_0(iq) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
+        enddo !do ixt= niso_possibles
+       enddo !do phase=1,nqo
+  20   continue
+      enddo !do iq=1,nqtot
+
+      write(lunout,*) 'iso_num=',iso_num
+      write(lunout,*) 'iso_indnum=',iso_indnum
+      write(lunout,*) 'zone_num=',zone_num  
+      write(lunout,*) 'phase_num=',phase_num
+      write(lunout,*) 'indnum_fn_num=',indnum_fn_num
+
+      do ixt= 1,niso_possibles  
+
+        if (nb_iso(ixt,1).eq.1) then
+          ! on vérifie que toutes les phases ont le même nombre de
+          ! traceurs
+          do phase=2,nqo
+            if (nb_iso(ixt,phase).ne.nb_iso(ixt,1)) then
+              write(lunout,*) 'ixt,phase,nb_iso=',ixt,phase,nb_iso(ixt,phase)
+              CALL abort_gcm('infotrac_init','Phases must have same number of isotopes',1)
+            endif
+          enddo !do phase=2,nqo
+
+          niso=niso+1
+          use_iso(ixt)=.true.
+          ntraceurs_zone=nb_traciso(ixt,1)
+
+          ! on vérifie que toutes les phases ont le même nombre de
+          ! traceurs
+          do phase=2,nqo
+            if (nb_traciso(ixt,phase).ne.ntraceurs_zone) then
+              write(lunout,*) 'ixt,phase,nb_traciso=',ixt,phase,nb_traciso(ixt,phase)
+              write(lunout,*) 'ntraceurs_zone=',ntraceurs_zone
+              CALL abort_gcm('infotrac_init','Phases must have same number of tracers',1)
+            endif  
+          enddo  !do phase=2,nqo
+          ! on vérifie que tous les isotopes ont le même nombre de
+          ! traceurs
+          if (ntraceurs_zone_prec.gt.0) then               
+            if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
+              ntraceurs_zone_prec=ntraceurs_zone
+            else !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
+              write(*,*) 'ntraceurs_zone_prec,ntraceurs_zone=',ntraceurs_zone_prec,ntraceurs_zone   
+              CALL abort_gcm('infotrac_init', &
+               &'Isotope tracers are not well defined in traceur.def',1)           
+            endif !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
+           endif !if (ntraceurs_zone_prec.gt.0) then
+
+        else if (nb_iso(ixt,1).ne.0) then
+           WRITE(lunout,*) 'nqo,ixt=',nqo,ixt
+           WRITE(lunout,*) 'nb_iso(ixt,1)=',nb_iso(ixt,1)    
+           CALL abort_gcm('infotrac_init','Isotopes are not well defined in traceur.def',1)     
+        endif   !if (nb_iso(ixt,1).eq.1) then       
+    enddo ! do ixt= niso_possibles
+
+    ! dimensions isotopique:
+    ntraciso=niso*(ntraceurs_zone+1)
+    WRITE(lunout,*) 'niso=',niso
+    WRITE(lunout,*) 'ntraceurs_zone,ntraciso=',ntraceurs_zone,ntraciso    
+ 
+    ! flags isotopiques:
+    if (niso.gt.0) then
+        ok_isotopes=.true.
+    else
+        ok_isotopes=.false.
+    endif 
+    WRITE(lunout,*) 'ok_isotopes=',ok_isotopes
+ 
+    if (ok_isotopes) then
+        ok_iso_verif=.false.
+        call getin('ok_iso_verif',ok_iso_verif)
+        ok_init_iso=.false.
+        call getin('ok_init_iso',ok_init_iso)
+        tnat=(/1.0,155.76e-6,2005.2e-6,0.004/100.,0.0/)
+        alpha_ideal=(/1.0,1.01,1.006,1.003,1.0/)
+    endif !if (ok_isotopes) then  
+    WRITE(lunout,*) 'ok_iso_verif=',ok_iso_verif
+    WRITE(lunout,*) 'ok_init_iso=',ok_init_iso
+
+    if (ntraceurs_zone.gt.0) then
+        ok_isotrac=.true.
+    else
+        ok_isotrac=.false.
+    endif   
+    WRITE(lunout,*) 'ok_isotrac=',ok_isotrac
+
+    ! remplissage du tableau iqiso(ntraciso,phase)
+    ALLOCATE(iqiso(ntraciso,nqo))   
+    iqiso(:,:)=0     
+    do iq=1,nqtot
+        if (iso_num(iq).gt.0) then
+          ixt=iso_indnum(iq)+zone_num(iq)*niso
+          iqiso(ixt,phase_num(iq))=iq
+        endif
+    enddo
+    WRITE(lunout,*) 'iqiso=',iqiso
+
+    ! replissage du tableau index_trac(ntraceurs_zone,niso)
+    ALLOCATE(index_trac(ntraceurs_zone,niso))  
+    if (ok_isotrac) then
+        do iiso=1,niso
+          do izone=1,ntraceurs_zone 
+             index_trac(izone,iiso)=iiso+izone*niso
+          enddo
+        enddo
+    else !if (ok_isotrac) then      
+        index_trac(:,:)=0.0
+    endif !if (ok_isotrac) then
+    write(lunout,*) 'index_trac=',index_trac    
+
+! Finalize :
+    DEALLOCATE(nb_iso)
+
+  END SUBROUTINE infotrac_isoinit
+
 END MODULE infotrac
Index: LMDZ5/branches/testing/libf/dyn3d_common/iniprint.h
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/iniprint.h	(revision 2274)
+++ 	(revision )
@@ -1,11 +1,0 @@
-!
-! $Header$
-!
-!
-! gestion des impressions de sorties et de débogage
-! lunout:    unité du fichier dans lequel se font les sorties 
-!                           (par defaut 6, la sortie standard)
-! prt_level: niveau d'impression souhaité (0 = minimum)
-!
-      INTEGER lunout, prt_level
-      COMMON /comprint/ lunout, prt_level
Index: LMDZ5/branches/testing/libf/dyn3d_common/initdynav.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/initdynav.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/initdynav.F90	(revision 2298)
@@ -0,0 +1,194 @@
+! $Id$
+
+subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+  USE IOIPSL
+#endif
+  USE infotrac, ONLY : nqtot, ttext
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
+       dynhistave_file,dynhistvave_file,dynhistuave_file
+  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 "comconst.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "temps.h"
+  include "ener.h"
+  include "logic.h"
+  include "description.h"
+  include "serre.h"
+  include "iniprint.h"
+
+  !   Arguments
+
+  integer day0, anne0
+  real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+  ! 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, ttext(iq), ttext(iq), '-', &
+  !                  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)
+#else
+  write(lunout,*)"initdynav: Warning this routine should not be", &
+       " used without ioipsl"
+#endif
+  ! of #ifdef CPP_IOIPSL
+
+end subroutine initdynav
Index: LMDZ5/branches/testing/libf/dyn3d_common/initfluxsto.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/initfluxsto.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/initfluxsto.F	(revision 2298)
@@ -0,0 +1,233 @@
+!
+! $Id$
+!
+      subroutine initfluxsto
+     .  (infile,tstep,t_ops,t_wrt,
+     .                    fileid,filevid,filedid)
+
+#ifdef CPP_IOIPSL
+       USE IOIPSL
+#endif
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep: duree du pas de temps en seconde
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C      filevid:ID du fichier netcdf pour la grille v
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      real nivd(1)
+      integer tau0
+      real zjulian
+      character*3 str
+      character*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
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+      ok_sync = .true.
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      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)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  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)
+
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      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)
+	
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              llm, nivsigs, zvertiid)
+c pour le fichier def
+      nivd(1) = 1
+      call histvert(filedid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              1, nivd, dvertiid)
+
+C
+C  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)
+
+
+C
+C Masse 
+C
+      call histdef(fileid, 'masse', 'Masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbaru 
+C
+      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)
+
+C
+C  Pbarv 
+C
+      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)
+C
+C  w 
+C
+      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)
+
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C Geopotentiel 
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      call histend(filedid)
+      if (ok_sync) then
+        call histsync(fileid)
+        call histsync(filevid)
+        call histsync(filedid)
+      endif
+	
+#else
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"initfluxsto: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/branches/testing/libf/dyn3d_common/inithist.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/inithist.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/inithist.F	(revision 2298)
@@ -0,0 +1,197 @@
+!
+! $Id$
+!
+      subroutine inithist(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+       USE IOIPSL
+#endif
+       USE infotrac, ONLY : nqtot, ttext
+       use com_io_dyn_mod, only : histid,histvid,histuid,               &
+     &                        dynhist_file,dynhistv_file,dynhistu_file
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep: duree du pas de temps en seconde
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C      nq: nombre de traceurs
+C
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      integer day0, anne0
+      real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, dayref
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      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)
+! -------------------------------------------------------------
+C  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')
+C
+! -------------------------------------------------------------
+C  Appels a histdef pour la definition des variables a sauvegarder
+! -------------------------------------------------------------
+C
+C  Vents U
+C
+      call histdef(histuid, 'u', 'vent u', 'm/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      call histdef(histvid, 'v', 'vent v', 'm/s',
+     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(histid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Geopotentiel
+C
+      call histdef(histid, 'phi', 'geopotentiel', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+!
+!        DO iq=1,nqtot
+!          call histdef(histid, ttext(iq),  ttext(iq), '-',
+!     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+!     .             32, 'inst(X)', t_ops, t_wrt)
+!        enddo
+!C
+C  Masse
+C
+      call histdef(histid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  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
+C  Fin
+C
+      call histend(histid)
+      call histend(histuid)
+      call histend(histvid)
+#else
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"inithist: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/branches/testing/libf/dyn3d_common/initial0.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/initial0.F	(revision 2274)
+++ 	(revision )
@@ -1,12 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE initial0(n,x)
-      IMPLICIT NONE
-      INTEGER n,i
-      REAL x(n)
-      DO 10 i=1,n
-         x(i)=0.
-10    CONTINUE
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3d_common/iso_verif_dyn.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/iso_verif_dyn.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/iso_verif_dyn.F	(revision 2298)
@@ -0,0 +1,101 @@
+        function iso_verif_noNaN_nostop(x,err_msg)
+        implicit none
+        ! si x est NaN, on affiche message
+        ! d'erreur et return 1 si erreur
+
+        ! input:
+        real x
+        character*(*) err_msg ! message d''erreur à afficher
+
+        ! output 
+        real borne
+        parameter (borne=1e19)
+        integer iso_verif_noNaN_nostop
+
+        if ((x.gt.-borne).and.(x.lt.borne)) then
+                iso_verif_noNAN_nostop=0
+        else
+            write(*,*) 'erreur detectee par iso_verif_nonNaN:'
+            write(*,*) err_msg
+            write(*,*) 'x=',x
+            iso_verif_noNaN_nostop=1
+        endif      
+
+        return
+        end
+
+        function iso_verif_egalite_nostop
+     :           (a,b,err_msg)
+        implicit none
+        ! compare a et b. Si pas egal, on affiche message
+        ! d'erreur et stoppe
+        ! pour egalite, on verifie erreur absolue et arreur relative
+
+        ! input:
+        real a, b
+        character*(*) err_msg ! message d''erreur à afficher
+
+        ! locals
+        real errmax ! erreur maximale en absolu.
+        real errmaxrel ! erreur maximale en relatif autorisée
+        parameter (errmax=1e-8)
+        parameter (errmaxrel=1e-3)
+
+        ! output
+        integer iso_verif_egalite_nostop
+
+        iso_verif_egalite_nostop=0
+
+        if (abs(a-b).gt.errmax) then
+          if (abs((a-b)/max(max(abs(b),abs(a)),1e-18))
+     :            .gt.errmaxrel) then
+            write(*,*) 'erreur detectee par iso_verif_egalite:'
+            write(*,*) err_msg
+            write(*,*) 'a=',a
+            write(*,*) 'b=',b
+            iso_verif_egalite_nostop=1
+          endif
+        endif     
+        
+        return
+        end        
+
+
+        function iso_verif_aberrant_nostop
+     :           (x,iso,q,err_msg)
+        USE infotrac
+        implicit none
+        
+        ! input:
+        real x,q
+        integer iso ! 2=HDO, 1=O18
+        character*(*) err_msg ! message d''erreur à afficher
+
+        ! locals
+        real qmin,deltaD
+        real deltaDmax,deltaDmin
+        parameter (qmin=1e-11)
+        parameter (deltaDmax=200.0,deltaDmin=-999.9)
+
+        ! output
+        integer iso_verif_aberrant_nostop
+
+        iso_verif_aberrant_nostop=0
+
+        ! verifier que HDO est raisonable
+         if (q.gt.qmin) then
+             deltaD=(x/q/tnat(iso)-1)*1000
+             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur detectee par iso_verif_aberrant:'
+                  write(*,*) err_msg
+                  write(*,*) 'q=',q
+                  write(*,*) 'deltaD=',deltaD
+                  write(*,*) 'iso=',iso
+                  iso_verif_aberrant_nostop=1
+             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+          endif !if (q(i,k,iq).gt.qmin) then
+
+       
+        return
+        end        
+
Index: LMDZ5/branches/testing/libf/dyn3d_common/juldate.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/juldate.F	(revision 2274)
+++ 	(revision )
@@ -1,39 +1,0 @@
-!
-! $Id$
-!
-	subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
-c	Sous-routine de changement de date:
-c	gregorien>>>date julienne
-c	En entree:an,mois,jour,heure,min.,sec.
-c	En sortie:tjd
-        IMPLICIT NONE
-        INTEGER,INTENT(IN) :: ian,imoi,ijou,oh,om,os
-        REAL,INTENT(OUT) :: tjd,tjdsec
-        
-        REAL frac,year,rmon,cf,a,b
-        INTEGER ojou
-        
-	frac=((os/60.+om)/60.+oh)/24.
-	ojou=dble(ijou)+frac
-	    year=dble(ian)
-	    rmon=dble(imoi)
-	if (imoi .le. 2) then
-	    year=year-1.
-	    rmon=rmon+12.
-	endif
-	cf=year+(rmon/100.)+(ojou/10000.)
-	if (cf .ge. 1582.1015) then
-	    a=int(year/100)
-	    b=2-a+int(a/4)
-	else
-	    b=0
-	endif
-	tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou)
-     +   +1720994.5+b
-        tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
-        tjd=int(tjd)+int(tjdsec)
-	tjdsec=tjdsec-int(tjdsec)
-	return
-	end
-
-
Index: LMDZ5/branches/testing/libf/dyn3d_common/minmax.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/minmax.F	(revision 2274)
+++ 	(revision )
@@ -1,23 +1,0 @@
-!
-! $Header$
-!
-       SUBROUTINE minmax(imax, xi, zmin, zmax )
-c
-c      P. Le Van
-
-       INTEGER imax
-       REAL    xi(imax)
-       REAL    zmin,zmax
-       INTEGER i
-
-       zmin = xi(1)
-       zmax = xi(1)
-
-       DO i = 2, imax
-         zmin = MIN( zmin,xi(i) )
-         zmax = MAX( zmax,xi(i) )
-       ENDDO
-
-       RETURN
-       END
-
Index: LMDZ5/branches/testing/libf/dyn3d_common/minmax2.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/minmax2.F	(revision 2274)
+++ 	(revision )
@@ -1,20 +1,0 @@
-!
-! $Header$
-!
-       SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax )
-c
-       INTEGER lmax,jmax,imax
-       REAL xi(imax*jmax*lmax) 
-       REAL zmin,zmax
-       INTEGER i
-    
-       zmin = xi(1)
-       zmax = xi(1)
-
-       DO i = 2, imax*jmax*lmax
-         zmin = MIN( zmin,xi(i) )
-         zmax = MAX( zmax,xi(i) )
-       ENDDO
-
-       RETURN
-       END
Index: LMDZ5/branches/testing/libf/dyn3d_common/ran1.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/ran1.F	(revision 2274)
+++ 	(revision )
@@ -1,38 +1,0 @@
-!
-! $Id$
-!
-      FUNCTION RAN1(IDUM)
-      IMPLICIT NONE
-      REAL RAN1
-      REAL,SAVE :: R(97)
-      REAL,PARAMETER :: RM1=3.8580247E-6,RM2=7.4373773E-6
-      INTEGER,SAVE :: IFF=0
-      integer,save :: ix1,ix2,ix3
-      INTEGER,PARAMETER :: M1=259200,IA1=7141,IC1=54773
-      INTEGER,PARAMETER :: M2=134456,IA2=8121,IC2=28411
-      INTEGER,PARAMETER :: M3=243000,IA3=4561,IC3=51349
-      INTEGER :: IDUM,J
-
-      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
-        IFF=1
-        IX1=MOD(IC1-IDUM,M1)
-        IX1=MOD(IA1*IX1+IC1,M1)
-        IX2=MOD(IX1,M2)
-        IX1=MOD(IA1*IX1+IC1,M1)
-        IX3=MOD(IX1,M3)
-        DO 11 J=1,97
-          IX1=MOD(IA1*IX1+IC1,M1)
-          IX2=MOD(IA2*IX2+IC2,M2)
-          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
-11      CONTINUE
-        IDUM=1
-      ENDIF
-      IX1=MOD(IA1*IX1+IC1,M1)
-      IX2=MOD(IA2*IX2+IC2,M2)
-      IX3=MOD(IA3*IX3+IC3,M3)
-      J=1+(97*IX3)/M3
-      IF(J.GT.97.OR.J.LT.1) stop 1
-      RAN1=R(J)
-      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3d_common/sort.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/sort.F	(revision 2274)
+++ 	(revision )
@@ -1,37 +1,0 @@
-!
-! $Header$
-!
-C
-C
-      SUBROUTINE sort(n,d)
-c
-c     P.Le Van
-c      
-c...  cette routine met le tableau d  dans l'ordre croissant  ....
-cc   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
-c      tion  situee + bas  IF(d(j).LE.p)  THEN     par
-c                           IF(d(j).GE.p)  THEN
-c
-
-      INTEGER n
-      REAL d(n) , p
-      INTEGER i,j,k
-
-      DO i=1,n-1
-        k=i
-        p=d(i)
-        DO j=i+1,n
-         IF(d(j).LE.p) THEN
-           k=j
-           p=d(j)
-         ENDIF
-        ENDDO
-
-       IF(k.ne.i) THEN
-         d(k)=d(i)
-         d(i)=p
-       ENDIF
-      ENDDO
-
-       RETURN
-       END
Index: LMDZ5/branches/testing/libf/dyn3d_common/write_field.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/write_field.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/write_field.F90	(revision 2298)
@@ -0,0 +1,326 @@
+!
+! $Id$
+!
+module write_field
+implicit none
+
+  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  
+  
+  function int2str(int)
+    implicit none
+    integer, parameter :: MaxLen=10
+    integer,intent(in) :: int
+    character(len=MaxLen) :: int2str
+    logical :: flag
+    integer :: i
+    flag=.true.
+    
+    i=int
+    
+    int2str=''
+    do while (flag)
+      int2str=CHAR(MOD(i,10)+48)//int2str
+      i=i/10
+      if (i==0) flag=.false.
+    enddo
+  end function int2str
+
+end module write_field
+  
Index: LMDZ5/branches/testing/libf/dyn3d_common/writedynav.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/writedynav.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/writedynav.F90	(revision 2298)
@@ -0,0 +1,141 @@
+! $Id$
+
+subroutine writedynav(time, vcov, ucov, teta, ppk, phi, q, masse, ps, phis)
+
+#ifdef CPP_IOIPSL
+  USE ioipsl
+#endif
+  USE infotrac, ONLY : nqtot, ttext
+  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
+
+  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 "comconst.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "temps.h"
+  include "ener.h"
+  include "logic.h"
+  include "description.h"
+  include "serre.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
+
+#ifdef CPP_IOIPSL
+  ! 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, ttext(iq), 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
+
+#else
+  write(lunout, *) "writedynav: Warning this routine should not be", &
+       " used without ioipsl"
+#endif
+  ! of #ifdef CPP_IOIPSL
+
+end subroutine writedynav
Index: LMDZ5/branches/testing/libf/dyn3d_common/writehist.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3d_common/writehist.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3d_common/writehist.F	(revision 2298)
@@ -0,0 +1,136 @@
+!
+! $Id$
+!
+      subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+      USE ioipsl
+#endif
+      USE infotrac, ONLY : nqtot, ttext
+      use com_io_dyn_mod, only : histid,histvid,histuid
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      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
+
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      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)
+
+C
+C  Initialisations
+C
+      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)
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      call histwrite(histuid, 'u', itau_w, unat, 
+     .               iip1*jjp1*llm, ndexu)
+C
+C  Vents V
+C
+      call histwrite(histvid, 'v', itau_w, vnat, 
+     .               iip1*jjm*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      call histwrite(histid, 'teta', itau_w, teta, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Traceurs
+C
+!        DO iq=1,nqtot
+!          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), 
+!     .                   iip1*jjp1*llm, ndexu)
+!        enddo
+!C
+C  Masse
+C
+      call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+C
+C  Geopotentiel au sol
+C
+!      call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+        call histsync(histuid)
+      endif
+#else
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"writehist: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/branches/testing/libf/dyn3dmem/advtrac_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/advtrac_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/advtrac_loc.F	(revision 2298)
@@ -24,5 +24,5 @@
       USE Vampir
       USE times
-      USE infotrac, ONLY: nqtot, iadv
+      USE infotrac, ONLY: nqtot, iadv, ok_iso_verif
       USE control_mod, ONLY: iapp_tracvl, day_step, planet_type
       USE advtrac_mod, ONLY: finmasse
@@ -82,5 +82,5 @@
 !$OMP THREADPRIVATE(testRequest)
 
-c  test sur l'eventuelle creation de valeurs negatives de la masse
+c  test sur l''eventuelle creation de valeurs negatives de la masse
          ijb=ij_begin
          ije=ij_end
@@ -155,7 +155,13 @@
 c$OMP BARRIER
                  
+          !write(*,*) 'advtrac 157: appel de vlspltgen_loc'
           call vlspltgen_loc( q,iadv, 2., massem, wg ,
      *                        pbarug,pbarvg,dtvr,p,
      *                        pk,teta )
+
+          !write(*,*) 'advtrac 162: apres appel vlspltgen_loc'
+      if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'advtrac 162')
+      endif !if (ok_iso_verif) then
 
 #ifdef DEBUG_IO     
@@ -356,5 +362,6 @@
 c$OMP END DO
 
-       CALL qminimum_loc( q, 2, finmasse )
+        ! CRisi: on passe nqtot et non nq
+       CALL qminimum_loc( q, nqtot, finmasse )
 
       endif ! of if (planet_type=="earth")
Index: LMDZ5/branches/testing/libf/dyn3dmem/caladvtrac_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/caladvtrac_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/caladvtrac_loc.F	(revision 2298)
@@ -56,5 +56,5 @@
 !$OMP THREADPRIVATE(Request_vanleer)
 
-           
+      !write(*,*) 'caladvtrac 58: entree'     
       ijbu=ij_begin
       ijeu=ij_end
@@ -109,4 +109,5 @@
 
       IF ( iadvtr.EQ.iapp_tracvl ) THEN
+      !write(*,*) 'caladvtrac 133'
 c$OMP MASTER
         call suspend_timer(timer_caldyn)
@@ -183,7 +184,9 @@
          CALL WriteField_u('wg1',wg_adv)
 #endif        
+      !write(*,*) 'caladvtrac 185'  
       CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, 
      *             p_adv,  massem_adv,q_adv, teta_adv,
-     .             pk_adv)
+     .             pk_adv)     
+      !write(*,*) 'caladvtrac 189'
 
 
Index: LMDZ5/branches/testing/libf/dyn3dmem/calfis_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/calfis_loc.F	(revision 2274)
+++ 	(revision )
@@ -1,1189 +1,0 @@
-!
-! $Id$
-!
-C
-C
-      SUBROUTINE calfis_loc(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)
-#ifdef CPP_PHYS
-! If using physics
-c
-c    Auteur :  P. Le Van, F. Hourdin 
-c   .........
-      USE dimphy
-      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
-      USE mod_interface_dyn_phys
-      USE IOPHY
-#endif
-      USE parallel_lmdz,ONLY:omp_chunk,using_mpi,jjb_u,jje_u,jjb_v,jje_v
-      USE Write_Field
-      Use Write_field_p
-      USE Times
-      USE infotrac, ONLY: nqtot, niadv, tname
-      USE control_mod, ONLY: planet_type, nsplit_phys
-
-      IMPLICIT NONE
-c=======================================================================
-c
-c   1. rearrangement des tableaux et transformation
-c      variables dynamiques  >  variables physiques
-c   2. calcul des termes physiques
-c   3. retransformation des tendances physiques en tendances dynamiques
-c
-c   remarques:
-c   ----------
-c
-c    - les vents sont donnes dans la physique par leurs composantes 
-c      naturelles.
-c    - la variable thermodynamique de la physique est une variable
-c      intensive :   T 
-c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
-c    - les deux seules variables dependant de la geometrie necessaires
-c      pour la physique sont la latitude pour le rayonnement et 
-c      l'aire de la maille quand on veut integrer une grandeur 
-c      horizontalement.
-c    - les points de la physique sont les points scalaires de la 
-c      la dynamique; numerotation:
-c          1 pour le pole nord
-c          (jjm-1)*iim pour l'interieur du domaine
-c          ngridmx pour le pole sud
-c      ---> ngridmx=2+(jjm-1)*iim
-c
-c     Input :
-c     -------
-c       ecritphy        frequence d'ecriture (en jours)de histphy
-c       pucov           covariant zonal velocity
-c       pvcov           covariant meridional velocity 
-c       pteta           potential temperature
-c       pps             surface pressure
-c       pmasse          masse d'air dans chaque maille
-c       pts             surface temperature  (K)
-c       callrad         clef d'appel au rayonnement
-c
-c    Output :
-c    --------
-c        pdufi          tendency for the natural zonal velocity (ms-1)
-c        pdvfi          tendency for the natural meridional velocity 
-c        pdhfi          tendency for the potential temperature
-c        pdtsfi         tendency for the surface temperature
-c
-c        pdtrad         radiative tendencies  \  both input
-c        pfluxrad       radiative fluxes      /  and output
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "temps.h"
-
-      INTEGER ngridmx
-      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
-
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "iniprint.h"
-#ifdef CPP_MPI
-      include 'mpif.h'
-#endif
-c    Arguments :
-c    -----------
-      LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
-      REAL,INTENT(IN):: jD_cur, jH_cur
-      REAL,INTENT(IN):: pvcov(iip1,jjb_v:jje_v,llm) ! covariant meridional velocity
-      REAL,INTENT(IN):: pucov(iip1,jjb_u:jje_u,llm) ! covariant zonal velocity
-      REAL,INTENT(IN):: pteta(iip1,jjb_u:jje_u,llm) ! potential temperature
-      REAL,INTENT(IN):: pmasse(iip1,jjb_u:jje_u,llm) ! mass in each cell ! not used
-      REAL,INTENT(IN):: pq(iip1,jjb_u:jje_u,llm,nqtot) ! tracers
-      REAL,INTENT(IN):: pphis(iip1,jjb_u:jje_u) ! surface geopotential
-      REAL,INTENT(IN):: pphi(iip1,jjb_u:jje_u,llm) ! geopotential
-
-      REAL,INTENT(IN) :: pdvcov(iip1,jjb_v:jje_v,llm) ! dynamical tendency on vcov ! not used
-      REAL,INTENT(IN) :: pducov(iip1,jjb_u:jje_u,llm) ! dynamical tendency on ucov
-      REAL,INTENT(IN) :: pdteta(iip1,jjb_u:jje_u,llm) ! dynamical tendency on teta ! not used
-      REAL,INTENT(IN) :: pdq(iip1,jjb_u:jje_u,llm,nqtot) ! dynamical tendency on tracers ! not used
-
-      REAL,INTENT(IN) :: pps(iip1,jjb_u:jje_u) ! surface pressure (Pa)
-      REAL,INTENT(IN) :: pp(iip1,jjb_u:jje_u,llmp1) ! pressure at mesh interfaces (Pa)
-      REAL,INTENT(IN) :: ppk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
-      REAL,INTENT(IN) :: flxw(iip1,jjb_u:jje_u,llm)  ! Vertical mass flux on dynamics grid
-
-      ! tendencies (in */s) from the physics
-      REAL,INTENT(OUT) :: pdvfi(iip1,jjb_v:jje_v,llm) ! tendency on covariant meridional wind
-      REAL,INTENT(OUT) :: pdufi(iip1,jjb_u:jje_u,llm) ! tendency on covariant zonal wind
-      REAL,INTENT(OUT) :: pdhfi(iip1,jjb_u:jje_u,llm) ! tendency on potential temperature (K/s)
-      REAL,INTENT(OUT) :: pdqfi(iip1,jjb_u:jje_u,llm,nqtot) ! tendency on tracers
-      REAL,INTENT(OUT) :: pdpsfi(iip1,jjb_u:jje_u) ! tendency on surface pressure (Pa/s)
-
-#ifdef CPP_PHYS
-! Ehouarn: for now calfis_p needs some informations from physics to compile
-c    Local variables :
-c    -----------------
-
-      INTEGER i,j,l,ig0,ig,iq,iiq
-      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
-      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
-c
-      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
-      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
-c
-      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
-      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
-c
-      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
-      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
-
-c
-      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
-      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
-      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
-      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
-      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Introduction du splitting (FH)
-! Question pour Yann :
-! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
-! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
-! soit allocatable (plutot par exemple que de passer une dimension
-! dépendant du process en argument des routines) et que, du coup,
-! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
-! Tu confirmes ?
-! J'ai suivi le même principe pour les zdufic_omp
-! Mais c'est surement bien que tu controles.
-! 
-
-      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
-      REAL jH_cur_split,zdt_split
-      LOGICAL debut_split,lafin_split
-      INTEGER isplit
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
-c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
-c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
-c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
-c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
-
-      LOGICAL,SAVE :: first_omp=.true.
-c$OMP THREADPRIVATE(first_omp)
-      
-      REAL zsin(iim),zcos(iim),z1(iim)
-      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
-      REAL unskap, pksurcp
-c
-      REAL SSUM
-
-      LOGICAL,SAVE :: firstcal=.true., debut=.true.
-c$OMP THREADPRIVATE(firstcal,debut)
-      
-      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
-      INTEGER :: ierr
-#ifdef CPP_MPI
-      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
-#else
-      INTEGER,dimension(1,4) :: Status
-#endif
-      INTEGER, dimension(4) :: Req
-      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
-      integer :: k,kstart,kend
-      INTEGER :: offset
-
-      LOGICAL tracerdyn  
-c
-c-----------------------------------------------------------------------
-c
-c    1. Initialisations :
-c    --------------------
-c
-
-      klon=klon_mpi
-      
-c
-      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
-          STOP
-        ENDIF
-c$OMP MASTER
-      ALLOCATE(zpsrf(klon))
-      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
-      ALLOCATE(zphi(klon,llm),zphis(klon))
-      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
-      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
-      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
-      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
-      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
-      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
-      ALLOCATE(zdpsrf(klon))
-      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
-      ALLOCATE(flxwfi(klon,llm))
-c$OMP END MASTER
-c$OMP BARRIER	  
-      ELSE
-          debut = .FALSE.
-      ENDIF
-
-c
-c
-c-----------------------------------------------------------------------
-c   40. transformation des variables dynamiques en variables physiques:
-c   ---------------------------------------------------------------
-
-c   41. pressions au sol (en Pascals)
-c   ----------------------------------
-
-c$OMP MASTER
-      call start_timer(timer_physic)
-c$OMP END MASTER
-
-c$OMP MASTER             
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-      do ig0=1,klon
-        i=index_i(ig0)
-        j=index_j(ig0)
-        zpsrf(ig0)=pps(i,j)
-      enddo
-c$OMP END MASTER
-
-
-c   42. pression intercouches :
-c
-c   -----------------------------------------------------------------
-c     .... zplev  definis aux (llm +1) interfaces des couches  ....
-c     .... zplay  definis aux (  llm )    milieux des couches  .... 
-c   -----------------------------------------------------------------
-
-c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
-c
-       unskap   = 1./ kappa
-c
-c      print *,omp_rank,'klon--->',klon
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1, llmp1
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        do ig0=1,klon
-          i=index_i(ig0)
-          j=index_j(ig0)
-          zplev( ig0,l ) = pp(i,j,l)
-        enddo
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c
-
-c   43. temperature naturelle (en K) et pressions milieux couches .
-c   ---------------------------------------------------------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        do ig0=1,klon
-          i=index_i(ig0)
-          j=index_j(ig0)
-          pksurcp        = ppk(i,j,l) / cpp
-          zplay(ig0,l)   = preff * pksurcp ** unskap
-          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
-        enddo
-
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   43.bis traceurs
-c   ---------------
-c
-
-      DO iq=1,nqtot
-         iiq=niadv(iq)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-           do ig0=1,klon
-             i=index_i(ig0)
-             j=index_j(ig0)
-             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
-           enddo
-         ENDDO
-c$OMP END DO NOWAIT	 
-      ENDDO
-
-
-c   Geopotentiel calcule par rapport a la surface locale:
-c   -----------------------------------------------------
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-           do ig0=1,klon
-             i=index_i(ig0)
-             j=index_j(ig0)
-             zphi(ig0,l)  = pphi(i,j,l)
-           enddo
-         ENDDO
-c$OMP END DO NOWAIT	 
-
-c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
-
-c$OMP MASTER
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-           do ig0=1,klon
-             i=index_i(ig0)
-             j=index_j(ig0)
-             zphis(ig0)  = pphis(i,j)
-           enddo
-c$OMP END MASTER
-
-
-c      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
-
-c$OMP BARRIER
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-	 DO ig=1,klon
-	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
-	 ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-      
-
-c
-c   45. champ u:
-c   ------------
-
-      kstart=1
-      kend=klon
-      
-      if (is_north_pole) kstart=2
-      if (is_south_pole) kend=klon-1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!CDIR SPARSE
-        do ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          if (i==1) then
-            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
-     $                         + pucov(1,j,l)/cu(1,j) )
-          else
-            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
-     $                       + pucov(i,j,l)/cu(i,j) )
-          endif
-        enddo
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   46.champ v:
-c   -----------
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        DO ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
-     $                       + pvcov(i,j,l)/cv(i,j) )
-    
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   47. champs de vents aux pole nord   
-c   ------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      if (is_north_pole) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO l=1,llm
-
-           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
-           DO i=2,iim
-              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
-           ENDDO
-  
-           DO i=1,iim
-              zcos(i)   = COS(rlonv(i))*z1(i)
-              zsin(i)   = SIN(rlonv(i))*z1(i)
-           ENDDO
-  
-           zufi(1,l)  = SSUM(iim,zcos,1)/pi
-           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
-  
-        ENDDO
-c$OMP END DO NOWAIT      
-      endif
-
-
-c   48. champs de vents aux pole sud:
-c   ---------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      if (is_south_pole) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO l=1,llm
-  
-         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
-           DO i=2,iim
-             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
-	   ENDDO
-  
-           DO i=1,iim
-              zcos(i)    = COS(rlonv(i))*z1(i)
-              zsin(i)    = SIN(rlonv(i))*z1(i)
-	   ENDDO
-  
-           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
-           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
-        ENDDO
-c$OMP END DO NOWAIT       
-      endif
-
-c On change de grille, dynamique vers physiq, pour le flux de masse verticale
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-           do ig0=1,klon
-             i=index_i(ig0)
-             j=index_j(ig0)
-             flxwfi(ig0,l)  = flxw(i,j,l)
-           enddo
-         ENDDO
-c$OMP END DO NOWAIT
-
-c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
-
-c-----------------------------------------------------------------------
-c   Appel de la physique:
-c   ---------------------
-
-
-c$OMP BARRIER
-      if (first_omp) then
-        klon=klon_omp
-
-        allocate(zplev_omp(klon,llm+1))
-        allocate(zplay_omp(klon,llm))
-        allocate(zphi_omp(klon,llm))
-        allocate(zphis_omp(klon))
-        allocate(presnivs_omp(llm))
-        allocate(zufi_omp(klon,llm))
-        allocate(zvfi_omp(klon,llm))
-        allocate(ztfi_omp(klon,llm))
-        allocate(zqfi_omp(klon,llm,nqtot))
-        allocate(zdufi_omp(klon,llm))
-        allocate(zdvfi_omp(klon,llm))
-        allocate(zdtfi_omp(klon,llm))
-        allocate(zdqfi_omp(klon,llm,nqtot))
-        allocate(zdufic_omp(klon,llm))
-        allocate(zdvfic_omp(klon,llm))
-        allocate(zdtfic_omp(klon,llm))
-        allocate(zdqfic_omp(klon,llm,nqtot))
-        allocate(zdpsrf_omp(klon))
-        allocate(flxwfi_omp(klon,llm))
-	first_omp=.false.
-      endif
-       
-	   
-      klon=klon_omp
-      offset=klon_omp_begin-1
-      
-      do l=1,llm+1
-        do i=1,klon
-          zplev_omp(i,l)=zplev(offset+i,l)
-	enddo 
-      enddo
-	  
-       do l=1,llm
-        do i=1,klon  
-	  zplay_omp(i,l)=zplay(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zphi_omp(i,l)=zphi(offset+i,l)
-	enddo 
-      enddo
-	
-      do i=1,klon
-	zphis_omp(i)=zphis(offset+i)
-      enddo 
-     
-	
-      do l=1,llm
-        presnivs_omp(l)=presnivs(l)
-      enddo 
-	
-      do l=1,llm
-        do i=1,klon
-	  zufi_omp(i,l)=zufi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zvfi_omp(i,l)=zvfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  ztfi_omp(i,l)=ztfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
-	  enddo
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdufi_omp(i,l)=zdufi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-          zdtfi_omp(i,l)=zdtfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
-	  enddo 
-        enddo
-      enddo
-      	
-      do i=1,klon
-	zdpsrf_omp(i)=zdpsrf(offset+i)
-      enddo 
-
-      do l=1,llm
-        do i=1,klon
-          flxwfi_omp(i,l)=flxwfi(offset+i,l)
-	enddo 
-      enddo
-      
-c$OMP BARRIER
-      
-
-!$OMP MASTER 
-!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys 
-!$OMP END MASTER
-      zdt_split=dtphys/nsplit_phys
-      zdufic_omp(:,:)=0.
-      zdvfic_omp(:,:)=0.
-      zdtfic_omp(:,:)=0.
-      zdqfic_omp(:,:,:)=0.
-
-#ifdef CPP_PHYS
-      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 physiq (klon,
-     .             llm,
-     .             debut_split,
-     .             lafin_split,
-     .             jD_cur,
-     .             jH_cur_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,
-     .             pducov)
-
-      else if ( planet_type=="generic" ) then
-
-      CALL physiq (klon,     !! ngrid
-     .             llm,            !! nlayer
-     .             nqtot,          !! nq
-     .             tname,          !! tracer names from dynamical core (given in infotrac)
-     .             debut_split,    !! firstcall 
-     .             lafin_split,    !! lastcall
-     .             jD_cur,         !! pday. see leapfrog_p 
-     .             jH_cur_split,   !! ptime "fraction of day"
-     .             zdt_split,      !! ptimestep
-     .             zplev_omp,  !! pplev
-     .             zplay_omp,  !! pplay
-     .             zphi_omp,   !! pphi
-     .             zufi_omp,   !! pu
-     .             zvfi_omp,   !! pv
-     .             ztfi_omp,   !! pt
-     .             zqfi_omp,   !! pq
-     .             flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
-     .             zdufi_omp,  !! pdu
-     .             zdvfi_omp,  !! pdv
-     .             zdtfi_omp,  !! pdt
-     .             zdqfi_omp,  !! pdq
-     .             zdpsrf_omp, !! pdpsrf
-     .             tracerdyn)      !! tracerdyn <-- utilite ???
-
-      endif ! of if (planet_type=="earth")
-
-
-         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
-         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
-         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
-         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
-
-         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
-         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
-         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
-         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
-
-      enddo
-
-#endif
-! of #ifdef CPP_PHYS
-
-
-      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
-      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
-      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
-      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
-
-c$OMP BARRIER
-
-      do l=1,llm+1
-        do i=1,klon
-          zplev(offset+i,l)=zplev_omp(i,l)
-	enddo 
-      enddo
-	  
-       do l=1,llm
-        do i=1,klon  
-	  zplay(offset+i,l)=zplay_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zphi(offset+i,l)=zphi_omp(i,l)
-	enddo 
-      enddo
-	
-
-      do i=1,klon
-	zphis(offset+i)=zphis_omp(i)
-      enddo 
-     
-	
-      do l=1,llm
-        presnivs(l)=presnivs_omp(l)
-      enddo 
-	
-      do l=1,llm
-        do i=1,klon
-	  zufi(offset+i,l)=zufi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zvfi(offset+i,l)=zvfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  ztfi(offset+i,l)=ztfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
-	  enddo
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdufi(offset+i,l)=zdufi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-          zdtfi(offset+i,l)=zdtfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
-	  enddo 
-        enddo
-      enddo
-      	
-      do i=1,klon
-	zdpsrf(offset+i)=zdpsrf_omp(i)
-      enddo 
-      
-
-      klon=klon_mpi
-500   CONTINUE
-c$OMP BARRIER
-
-c$OMP MASTER
-      call stop_timer(timer_physic)
-c$OMP END MASTER
-
-      IF (using_mpi) THEN
-            
-      if (MPI_rank>0) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-       DO l=1,llm      
-        du_send(1:iim,l)=zdufi(1:iim,l)
-        dv_send(1:iim,l)=zdvfi(1:iim,l)
-       ENDDO
-c$OMP END DO NOWAIT       
-
-c$OMP BARRIER
-#ifdef CPP_MPI 
-c$OMP MASTER
-!$OMP CRITICAL (MPI)
-        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
-     &                   COMM_LMDZ,Req(1),ierr)
-        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
-     &                  COMM_LMDZ,Req(2),ierr)
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-c$OMP BARRIER
-     
-      endif
-   
-      if (MPI_rank<MPI_Size-1) then
-c$OMP BARRIER
-#ifdef CPP_MPI 
-c$OMP MASTER      
-!$OMP CRITICAL (MPI)
-        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
-     &                 COMM_LMDZ,Req(3),ierr)
-        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
-     &                 COMM_LMDZ,Req(4),ierr)
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-      endif
-
-c$OMP BARRIER
-
-
-#ifdef CPP_MPI 
-c$OMP MASTER    
-!$OMP CRITICAL (MPI)
-      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
-        call MPI_WAITALL(4,Req(1),Status,ierr)
-      else if (MPI_rank>0) then
-        call MPI_WAITALL(2,Req(1),Status,ierr)
-      else if (MPI_rank <MPI_Size-1) then
-        call MPI_WAITALL(2,Req(3),Status,ierr)
-      endif
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-
-c$OMP BARRIER     
-
-      ENDIF ! using_mpi
-      
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-            
-        zdufi2(1:klon,l)=zdufi(1:klon,l)
-        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
-            
-        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
-        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
-
-        pdhfi(:,jj_begin,l)=0
-        pdqfi(:,jj_begin,l,:)=0
-        pdufi(:,jj_begin,l)=0
-        pdvfi(:,jj_begin,l)=0
-                
-        if (.not. is_south_pole) then
-          pdhfi(:,jj_end:jj_end+1,l)=0
-          pdqfi(:,jj_end:jj_end+1,l,:)=0
-          pdufi(:,jj_end:jj_end+1,l)=0
-          pdvfi(:,jj_end:jj_end+1,l)=0
-        endif
-      
-       ENDDO 
-c$OMP END DO NOWAIT
-
-c$OMP MASTER
-        pdpsfi(:,jj_begin)=0    
-       
-       if (.not. is_south_pole) then
-	 pdpsfi(:,jj_end:jj_end+1)=0
-       endif
-c$OMP END MASTER
-c-----------------------------------------------------------------------
-c   transformation des tendances physiques en tendances dynamiques:
-c   ---------------------------------------------------------------
-
-c  tendance sur la pression :
-c  -----------------------------------
-c      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
-
-c$OMP MASTER
-      kstart=1
-      kend=klon
-
-      if (is_north_pole) kstart=2
-      if (is_south_pole)  kend=klon-1
-
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-        do ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          pdpsfi(i,j) = zdpsrf(ig0)
-          if (i==1) pdpsfi(iip1,j) =  zdpsrf(ig0)
-         enddo          
-
-        if (is_north_pole) then
-            DO i=1,iip1
-              pdpsfi(i,1)    = zdpsrf(1)
-            enddo
-        endif
-        
-        if (is_south_pole) then
-            DO i=1,iip1
-              pdpsfi(i,jjp1) = zdpsrf(klon)
-            ENDDO
-        endif
-c$OMP END MASTER
-cc$OMP BARRIER
-
-c
-c   62. enthalpie potentielle
-c   ---------------------
-      
-      kstart=1
-      kend=klon
-
-      if (is_north_pole) kstart=2
-      if (is_south_pole)  kend=klon-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-        do ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
-          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
-         enddo          
-
-        if (is_north_pole) then
-            DO i=1,iip1
-              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
-            enddo
-        endif
-        
-        if (is_south_pole) then
-            DO i=1,iip1
-              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
-            ENDDO
-        endif
-      ENDDO
-c$OMP END DO NOWAIT
-      
-c   62. humidite specifique
-c   ---------------------
-! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
-!      DO iq=1,nqtot
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!         DO l=1,llm
-!!!cdir NODEP 
-!           do ig0=kstart,kend
-!             i=index_i(ig0)
-!             j=index_j(ig0)
-!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
-!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
-!           enddo
-!           
-!           if (is_north_pole) then
-!             do i=1,iip1
-!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
-!             enddo
-!           endif
-!           
-!           if (is_south_pole) then
-!             do i=1,iip1
-!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
-!             enddo
-!           endif
-!         ENDDO
-!c$OMP END DO NOWAIT
-!      ENDDO
-
-c   63. traceurs
-c   ------------
-C     initialisation des tendances
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        pdqfi(:,jj_begin:jj_end,l,:)=0.
-      ENDDO
-c$OMP END DO NOWAIT	 
-
-C
-!cdir NODEP
-      DO iq=1,nqtot
-         iiq=niadv(iq)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP           
-	     DO ig0=kstart,kend
-              i=index_i(ig0)
-              j=index_j(ig0)
-              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
-              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
-            ENDDO
-	    
-	    IF (is_north_pole) then
-	      DO i=1,iip1
-                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
-	      ENDDO
-	    ENDIF
-	    
-	    IF (is_south_pole) then
-	      DO i=1,iip1
-                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
-	      ENDDO
-	    ENDIF
-	    
-         ENDDO
-c$OMP END DO NOWAIT	 
-      ENDDO
-      
-c   65. champ u:
-c   ------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-         do ig0=kstart,kend
-           i=index_i(ig0)
-           j=index_j(ig0)
-           
-           if (i/=iim) then
-             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
-           endif
-           
-           if (i==1) then
-              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
-     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
-             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
-           endif
-         
-         enddo
-         
-         if (is_north_pole) then
-           DO i=1,iip1
-            pdufi(i,1,l)    = 0.
-           ENDDO
-         endif
-         
-         if (is_south_pole) then
-           DO i=1,iip1
-            pdufi(i,jjp1,l) = 0.
-           ENDDO
-         endif
-         
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   67. champ v:
-c   ------------
-
-      kstart=1
-      kend=klon
-
-      if (is_north_pole) kstart=2
-      if (is_south_pole)  kend=klon-1-iim
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-        do ig0=kstart,kend
-           i=index_i(ig0)
-           j=index_j(ig0)
-           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
-           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
-     $	                                    zdvfi2(ig0+iim,l))
-     $				          *cv(i,j)
-        enddo
-         
-      ENDDO
-c$OMP END DO NOWAIT
-
-
-c   68. champ v pres des poles:
-c   ---------------------------
-c      v = U * cos(long) + V * SIN(long)
-
-      if (is_north_pole) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        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,1,l)=
-     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
-          ENDDO
-
-          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
-
-        ENDDO
-c$OMP END DO NOWAIT
-
-      endif    
-      
-      if (is_south_pole) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-         DO l=1,llm
-  
-           DO i=1,iim
-              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
-     $        +zdvfi(klon,l)*SIN(rlonv(i))
-
-              pdvfi(i,jjm,l)=
-     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
-           ENDDO
-
-           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
-
-        ENDDO
-c$OMP END DO NOWAIT
-     
-      endif
-c-----------------------------------------------------------------------
-
-700   CONTINUE
- 
-      firstcal = .FALSE.
-
-#else 
-      write(lunout,*) 
-     & "calfis_p: for now can only work with parallel physics" 
-      stop 
-#endif 
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90	(revision 2298)
@@ -227,9 +227,10 @@
   !$OMP BARRIER
 
+#ifdef CPP_PHYS
     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  )
-
+#endif
     ijb=ij_begin
     ije=ij_end  
Index: LMDZ5/branches/testing/libf/dyn3dmem/check_isotopes_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/check_isotopes_loc.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3dmem/check_isotopes_loc.F	(revision 2298)
@@ -0,0 +1,215 @@
+        subroutine check_isotopes(q,ijb,ije,err_msg)
+        USE infotrac
+        USE parallel_lmdz
+        implicit none
+
+#include "dimensions.h"
+
+        ! inputs
+        integer ijb,ije ! peut être local et différent de ijb_u,ije_u, ex: dans qminimum
+        real q(ijb_u:ije_u,llm,nqtot)
+        character*(*) err_msg ! message d''erreur à afficher
+
+        ! locals
+        integer ixt,phase,k,i,iq,iiso,izone,ieau,iqeau
+        real xtractot,xiiso
+        real borne
+        real qmin
+        real errmax ! erreur maximale en absolu.
+        real errmaxrel ! erreur maximale en relatif autorisée
+        real deltaDmax,deltaDmin
+        real ridicule
+        parameter (borne=1e19)
+        parameter (errmax=1e-8)
+        parameter (errmaxrel=1e-3)
+        parameter (qmin=1e-11)
+        parameter (deltaDmax=200.0,deltaDmin=-999.9)
+        parameter (ridicule=1e-12)
+        real deltaD
+
+        if (ok_isotopes) then
+
+        !write(*,*) 'check_isotopes 31: err_msg=',err_msg
+        ! verifier que rien n'est NaN
+        do ixt=1,ntraciso
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            do k=1,llm
+              DO i = ijb,ije
+                if ((q(i,k,iq).gt.-borne).and.
+     :            (q(i,k,iq).lt.borne)) then
+                else !if ((x(ixt,i,j).gt.-borne).and.
+                  write(*,*) 'erreur detectee par iso_verif_noNaN:'
+                  write(*,*) err_msg
+                  write(*,*) 'q,i,k,iq=',q(i,k,iq),i,k,iq
+                  write(*,*) 'borne=',borne
+                  stop
+                endif  !if ((x(ixt,i,j).gt.-borne).and.
+              enddo !DO i = ijb,ije
+            enddo !do k=1,llm
+c$OMP END DO NOWAIT
+          enddo !do phase=1,nqo
+        enddo !do ixt=1,ntraciso
+
+        !write(*,*) 'check_isotopes 52'
+        ! verifier que l'eau normale est OK
+        if (use_iso(1)) then
+          ixt=indnum_fn_num(1)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            do k=1,llm
+            DO i = ijb,ije  
+              if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+     :          (abs((q(i,k,phase)-q(i,k,iq))/
+     :           max(max(abs(q(i,k,phase)),abs(q(i,k,iq))),1e-18))
+     :           .gt.errmaxrel)) then
+                  write(*,*) 'erreur detectee par iso_verif_egalite:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase,ijb=',ixt,phase,ijb
+                  write(*,*) 'q,iq,i,k=',q(i,k,iq),iq,i,k
+                  write(*,*) 'q(i,k,phase)=',q(i,k,phase)
+                  stop
+              endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+              ! bidouille pour éviter divergence:
+              q(i,k,iq)= q(i,k,phase) 
+            enddo ! DO i = ijb,ije
+            enddo !do k=1,llm
+c$OMP END DO NOWAIT
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(1)) then
+        
+        !write(*,*) 'check_isotopes 78'
+        ! verifier que HDO est raisonable
+        if (use_iso(2)) then
+          ixt=indnum_fn_num(2)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            do k=1,llm
+            DO i = ijb,ije
+            if (q(i,k,iq).gt.qmin) then
+             deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(2)-1)*1000
+             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur detectee par iso_verif_aberrant:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase=',ixt,phase
+                  write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
+                  write(*,*) 'q=',q(i,k,:)
+                  write(*,*) 'deltaD=',deltaD
+                  stop
+             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+            endif !if (q(i,k,iq).gt.qmin) then
+            enddo !DO i = ijb,ije
+            enddo !do k=1,llm
+c$OMP END DO NOWAIT
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(2)) then
+
+        !write(*,*) 'check_isotopes 103'
+        ! verifier que O18 est raisonable
+        if (use_iso(3)) then
+          ixt=indnum_fn_num(3)
+          do phase=1,nqo
+            iq=iqiso(ixt,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            do k=1,llm
+            DO i = ijb,ije
+            if (q(i,k,iq).gt.qmin) then
+             deltaD=(q(i,k,iq)/q(i,k,phase)/tnat(3)-1)*1000
+             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur detectee iso_verif_aberrant O18:'
+                  write(*,*) err_msg
+                  write(*,*) 'ixt,phase=',ixt,phase
+                  write(*,*) 'q,iq,i,k,=',q(i,k,phase),iq,i,k
+                  write(*,*) 'xt=',q(i,k,:)
+                  write(*,*) 'deltaO18=',deltaD
+                  stop
+             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+            endif !if (q(i,k,iq).gt.qmin) then
+            enddo !DO i = ijb,ije
+            enddo !do k=1,llm
+c$OMP END DO NOWAIT
+          enddo ! do phase=1,nqo 
+        endif !if (use_iso(2)) then
+
+
+        !write(*,*) 'check_isotopes 129'
+        if (ok_isotrac) then
+
+          if (use_iso(2).and.use_iso(1)) then
+            do izone=1,ntraceurs_zone
+             ixt=index_trac(izone,indnum_fn_num(2))
+             ieau=index_trac(izone,indnum_fn_num(1))
+             do phase=1,nqo
+               iq=iqiso(ixt,phase)
+               iqeau=iqiso(ieau,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+               do k=1,llm
+                DO i = ijb,ije
+                if (q(i,k,iq).gt.qmin) then
+                 deltaD=(q(i,k,iq)/q(i,k,iqeau)/tnat(2)-1)*1000
+                 if ((deltaD.gt.deltaDmax).or.
+     &                   (deltaD.lt.deltaDmin)) then
+                  write(*,*) 'erreur dans iso_verif_aberrant trac:'
+                  write(*,*) err_msg
+                  write(*,*) 'izone,phase=',izone,phase
+                  write(*,*) 'ixt,ieau=',ixt,ieau
+                  write(*,*) 'q,iq,i,k,=',q(i,k,iq),iq,i,k
+                  write(*,*) 'deltaD=',deltaD
+                  stop
+                 endif !if ((deltaD.gt.deltaDmax).or.
+                endif !if (q(i,k,iq).gt.qmin) then
+                enddo !DO i = ijb,ije
+                enddo  ! do k=1,llm
+c$OMP END DO NOWAIT
+              enddo ! do phase=1,nqo    
+            enddo !do izone=1,ntraceurs_zone
+          endif !if (use_iso(2).and.use_iso(1)) then
+
+          do iiso=1,niso
+           do phase=1,nqo
+              iq=iqiso(iiso,phase)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+              do k=1,llm
+                DO i = ijb,ije
+                   xtractot=0.0
+                   xiiso=q(i,k,iq)
+                   do izone=1,ntraceurs_zone
+                      iq=iqiso(index_trac(izone,iiso),phase)
+                      xtractot=xtractot+ q(i,k,iq)
+                   enddo !do izone=1,ntraceurs_zone
+                   if ((abs(xtractot-xiiso).gt.errmax).and.
+     :                  (abs(xtractot-xiiso)/
+     :                  max(max(abs(xtractot),abs(xiiso)),1e-18)
+     :                  .gt.errmaxrel)) then
+                  write(*,*) 'erreur detectee par iso_verif_traceurs:'
+                  write(*,*) err_msg
+                  write(*,*) 'iiso,phase=',iiso,phase
+                  write(*,*) 'i,k,=',i,k
+                  write(*,*) 'q(i,k,:)=',q(i,k,:)
+                  stop
+                 endif !if ((abs(q(i,k,phase)-q(i,k,iq)).gt.errmax).and.
+                  
+                 ! bidouille pour éviter divergence:
+                 if (abs(xtractot).gt.ridicule) then
+                   do izone=1,ntraceurs_zone
+                     ixt=index_trac(izone,iiso) 
+                     q(i,k,iq)=q(i,k,iq)/xtractot*xiiso
+                   enddo !do izone=1,ntraceurs_zone                
+                  endif !if ((abs(xtractot).gt.ridicule) then
+                enddo !DO i = ijb,ije
+              enddo !do k=1,llm
+c$OMP END DO NOWAIT
+           enddo !do phase=1,nqo
+          enddo !do iiso=1,niso
+
+        endif !if (ok_isotrac) then
+
+        endif ! if (ok_isotopes)
+        !write(*,*) 'check_isotopes 198'
+        
+        end
+
+
Index: LMDZ5/branches/testing/libf/dyn3dmem/dynetat0_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/dynetat0_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/dynetat0_loc.F	(revision 2298)
@@ -366,4 +366,19 @@
            write(lunout,*)"Il est donc initialise a zero"
            q(:,:,iq)=0.
+
+           ! CRisi: pour les isotopes, on peut faire init théorique
+           ! distill de Rayleigh très simplifiée
+           if (ok_isotopes) then
+              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.0)) then
+                q(:,:,iq)=q(:,:,iqpere(iq))                             &
+     &                   *tnat(iso_num(iq))                             &
+     &                   *(q(:,:,iqpere(iq))/30.e-3)                    &
+     &                   **(alpha_ideal(iso_num(iq))-1)
+              endif
+              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.1)) then
+                  q(:,:,iq)=q(:,:,iqiso(iso_indnum(iq),phase_num(iq)))
+              endif  
+           endif !if (ok_isotopes) then        
+
         ELSE
 #ifdef NC_DOUBLE
@@ -380,5 +395,9 @@
 
         ENDIF
-      ENDDO
+      ENDDO !DO iq=1,nqtot
+
+      if (ok_iso_verif) then
+         call check_isotopes(q,ijb_u,ije_u,'dynetat0_loc')
+      endif !if (ok_iso_verif) then
 
       DEALLOCATE(q_glo)
Index: LMDZ5/branches/testing/libf/dyn3dmem/gcm.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/gcm.F	(revision 2274)
+++ 	(revision )
@@ -1,504 +1,0 @@
-!
-! $Id: $
-!
-c
-c
-      PROGRAM gcm
-
-#ifdef CPP_IOIPSL
-      USE IOIPSL
-#endif
-
-      USE mod_const_mpi, ONLY: init_const_mpi
-      USE parallel_lmdz
-      USE infotrac
-      USE mod_interface_dyn_phys
-      USE mod_hallo
-      USE Bands
-      USE getparam
-      USE filtreg_mod
-      USE control_mod
-
-#ifdef INCA
-! Only INCA needs these informations (from the Earth's physics)
-      USE indice_sol_mod
-      USE mod_phys_lmdz_omp_data, ONLY: klon_omp 
-#endif
-
-#ifdef CPP_PHYS
-!      USE mod_grid_phy_lmdz
-!      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
-!      USE dimphy
-!      USE comgeomphy
-#endif
-      IMPLICIT NONE
-
-c      ......   Version  du 10/01/98    ..........
-
-c             avec  coordonnees  verticales hybrides 
-c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   GCM LMD nouvelle grille
-c
-c=======================================================================
-c
-c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
-c      et possibilite d'appeler une fonction f(y)  a derivee tangente
-c      hyperbolique a la  place de la fonction a derivee sinusoidale.
-c  ... Possibilite de choisir le schema pour l'advection de
-c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
-c
-c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
-c      Pour Van-Leer iadv=10
-c
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-#include "dimensions.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comdissnew.h"
-#include "comvert.h"
-#include "comgeom.h"
-#include "logic.h"
-#include "temps.h"
-#include "ener.h"
-#include "description.h"
-#include "serre.h"
-!#include "com_io_dyn.h"
-#include "iniprint.h"
-#include "tracstoke.h"
-
-#ifdef INCA
-! Only INCA needs these informations (from the Earth's physics)
-!#include "indicesol.h"
-#endif
-
-      REAL zdtvr
-
-c   variables dynamiques
-      REAL,ALLOCATABLE,SAVE  :: vcov(:,:),ucov(:,:) ! vents covariants
-      REAL,ALLOCATABLE,SAVE  :: teta(:,:)     ! temperature potentielle 
-      REAL, ALLOCATABLE,SAVE :: q(:,:,:)      ! champs advectes
-      REAL,ALLOCATABLE,SAVE  :: ps(:)         ! pression  au sol
-c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-      REAL,ALLOCATABLE,SAVE  :: masse(:,:)    ! masse d'air
-      REAL,ALLOCATABLE,SAVE  :: phis(:)       ! geopotentiel au sol
-c      REAL phi(ip1jmp1,llm)                  ! geopotentiel
-c      REAL w(ip1jmp1,llm)                    ! vitesse verticale
-
-c variables dynamiques intermediaire pour le transport
-
-c   variables pour le fichier histoire
-      REAL dtav      ! intervalle de temps elementaire
-
-      REAL time_0
-
-      LOGICAL lafin
-
-      real time_step, t_wrt, t_ops
-
-c+jld variables test conservation energie
-c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
-C     Tendance de la temp. potentiel d (theta)/ d t due a la 
-C     tansformation d'energie cinetique en energie thermique
-C     cree par la dissipation
-c      REAL dhecdt(ip1jmp1,llm)
-c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
-c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
-c      CHARACTER (len=15) :: ztit
-c-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
-
-
-c-----------------------------------------------------------------------
-c   Initialisations:
-c   ----------------
-
-      abort_message = 'last timestep reached'
-      modname = 'gcm'
-      descript = 'Run GCM LMDZ'
-      lafin    = .FALSE.
-      dynhist_file = 'dyn_hist'
-      dynhistave_file = 'dyn_hist_ave'
-
-
-
-c----------------------------------------------------------------------
-c  lecture des fichiers gcm.def ou run.def
-c  ---------------------------------------
-c
-      CALL conf_gcm( 99, .TRUE. )
-      if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm",
-     s "iphysiq must be a multiple of iperiod", 1)
-c
-c
-c------------------------------------
-c   Initialisation partie parallele
-c------------------------------------
-      CALL init_const_mpi
-
-      call init_parallel
-      call ini_getparam("out.def")
-      call Read_Distrib
-
-#ifdef CPP_PHYS
-        CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
-!#endif
-!      CALL set_bands
-!#ifdef CPP_PHYS
-      CALL Init_interface_dyn_phys
-#endif
-      CALL barrier
-
-      CALL set_bands
-      if (mpi_rank==0) call WriteBands
-      call Set_Distrib(distrib_caldyn)
-
-c$OMP PARALLEL
-      call Init_Mod_hallo
-c$OMP END PARALLEL
-
-!#ifdef CPP_PHYS
-!c$OMP PARALLEL
-!      call InitComgeomphy ! now done in iniphysiq
-!c$OMP END PARALLEL 
-!#endif
-
-c-----------------------------------------------------------------------
-c   Choix du calendrier
-c   -------------------
-
-c      calend = 'earth_365d'
-
-#ifdef CPP_IOIPSL
-      if (calend == 'earth_360d') then
-        call ioconf_calendar('360d')
-        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
-#endif
-
-      IF (type_trac == 'inca') THEN
-#ifdef INCA
-         call init_const_lmdz(
-     $        nbtr,anneeref,dayref,
-     $        iphysiq,day_step,nday, 
-     $        nbsrf, is_oce,is_sic,
-     $        is_ter,is_lic, calend)
-
-         call init_inca_para(
-     $        iim,jjm+1,llm,klon_glo,mpi_size,
-     $        distrib_phys,COMM_LMDZ)
-#endif
-      END IF
-
-c-----------------------------------------------------------------------
-c   Initialisation des traceurs
-c   ---------------------------
-c  Choix du nombre de traceurs et du schema pour l'advection
-c  dans fichier traceur.def, par default ou via INCA
-      call infotrac_init
-
-c Allocation de la tableau q : champs advectes   
-      ALLOCATE(ucov(ijb_u:ije_u,llm))
-      ALLOCATE(vcov(ijb_v:ije_v,llm))
-      ALLOCATE(teta(ijb_u:ije_u,llm))
-      ALLOCATE(masse(ijb_u:ije_u,llm))
-      ALLOCATE(ps(ijb_u:ije_u))
-      ALLOCATE(phis(ijb_u:ije_u))
-      ALLOCATE(q(ijb_u:ije_u,llm,nqtot))
-
-c-----------------------------------------------------------------------
-c   Lecture de l'etat initial :
-c   ---------------------------
-
-c  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_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
-        endif
-
-!        if (planet_type.eq."earth") then
-! Load an Earth-format start file
-         CALL dynetat0_loc("start.nc",vcov,ucov,
-     &              teta,q,masse,ps,phis, time_0)
-!        endif ! of if (planet_type.eq."earth")
-
-c       write(73,*) 'ucov',ucov
-c       write(74,*) 'vcov',vcov
-c       write(75,*) 'teta',teta
-c       write(76,*) 'ps',ps
-c       write(77,*) 'q',q
-
-      endif ! of if (read_start)
-
-c 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
-         CALL iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
-      endif
-
-c-----------------------------------------------------------------------
-c   Lecture des parametres de controle pour la simulation :
-c   -------------------------------------------------------
-c  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
-
-C
-C on remet le calendrier \`a zero si demande
-c
-      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
-          WRITE(lunout,*)'Je m''arrete'
-          CALL abort
-        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
-c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
-c        write(lunout,*)
-c     .  'GCM: Attention les dates initiales lues dans le fichier'
-c        write(lunout,*)
-c     .  ' restart ne correspondent pas a celles lues dans '
-c        write(lunout,*)' gcm.def'
-c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
-c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
-c        if (raz_date .ne. 1) then
-c          write(lunout,*)
-c     .    'GCM: On garde les dates du fichier restart'
-c        else
-c          annee_ref = anneeref
-c          day_ref = dayref
-c          day_ini = dayref
-c          itau_dyn = 0
-c          itau_phy = 0
-c          time_0 = 0.
-c          write(lunout,*)
-c     .   'GCM: On reinitialise a la date lue dans gcm.def'
-c        endif
-c      ELSE
-c        raz_date = 0
-c      endif
-
-#ifdef CPP_IOIPSL
-      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
-#else
-! Ehouarn: we still need to define JD_ref and JH_ref
-! and since we don't know how many days there are in a year
-! we set JD_ref to 0 (this should be improved ...)
-      jD_ref=0
-      jH_ref=0
-#endif
-
-      if (iflag_phys.eq.1) then
-      ! these initialisations have already been done (via iniacademic)
-      ! if running in SW or Newtonian mode
-c-----------------------------------------------------------------------
-c   Initialisation des constantes dynamiques :
-c   ------------------------------------------
-        dtvr = zdtvr
-        CALL iniconst
-
-c-----------------------------------------------------------------------
-c   Initialisation de la geometrie :
-c   --------------------------------
-        CALL inigeom
-
-c-----------------------------------------------------------------------
-c   Initialisation du filtre :
-c   --------------------------
-        CALL inifilr
-      endif ! of if (iflag_phys.eq.1)
-c
-c-----------------------------------------------------------------------
-c   Initialisation de la dissipation :
-c   ----------------------------------
-
-      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
-     *                tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
-
-c-----------------------------------------------------------------------
-c   Initialisation de la physique :
-c   -------------------------------
-      IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
-! Physics:
-#ifdef CPP_PHYS
-         CALL iniphysiq(iim,jjm,llm,daysec,day_ini,dtphys/nsplit_phys,
-     &                rlatu,rlonv,aire,cu,cv,rad,g,r,cpp,
-     &                iflag_phys)
-#endif
-      ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
-
-
-c-----------------------------------------------------------------------
-c   Initialisation des dimensions d'INCA :
-c   --------------------------------------
-      IF (type_trac == 'inca') THEN
-!$OMP PARALLEL
-#ifdef INCA
-         CALL init_inca_dim(klon_omp,llm,iim,jjm,
-     $        rlonu,rlatu,rlonv,rlatv)
-#endif
-!$OMP END PARALLEL
-      END IF
-
-c-----------------------------------------------------------------------
-c   Initialisation des I/O :
-c   ------------------------
-
-
-      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//)
-
-#ifdef CPP_IOIPSL
-      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)
-#endif
-
-!      if (planet_type.eq."earth") then
-! Write an Earth-format restart file
-        CALL dynredem0_loc("restart.nc", day_end, phis)
-!      endif
-
-      ecripar = .TRUE.
-
-#ifdef CPP_IOIPSL
-      time_step = zdtvr
-      IF (mpi_rank==0) then
-        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
-          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_loc(day_ref,annee_ref,time_step,t_ops,t_wrt)
-        END IF
-      ENDIF
-      dtav = iperiod*dtvr/daysec
-#endif
-! #endif of #ifdef CPP_IOIPSL
-
-c  Choix des frequences de stokage pour le offline
-c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
-c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
-      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
-      istphy=istdyn/iphysiq     
-
-
-c
-c-----------------------------------------------------------------------
-c   Integration temporelle du modele :
-c   ----------------------------------
-
-c       write(78,*) 'ucov',ucov
-c       write(78,*) 'vcov',vcov
-c       write(78,*) 'teta',teta
-c       write(78,*) 'ps',ps
-c       write(78,*) 'q',q
-
-c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logici/,/logicl/)
-      CALL leapfrog_loc(ucov,vcov,teta,ps,masse,phis,q,time_0)
-c$OMP END PARALLEL
-
-!      OPEN(unit=5487,file='ok_lmdz',status='replace')
-!      WRITE(5487,*) 'ok_lmdz'
-!      CLOSE(5487)
-      END
-
Index: LMDZ5/branches/testing/libf/dyn3dmem/gcm.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/gcm.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dyn3dmem/gcm.F90	(revision 2298)
@@ -0,0 +1,500 @@
+! $Id: $
+
+PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+  USE IOIPSL
+#endif
+
+  USE mod_const_mpi, ONLY: init_const_mpi
+  USE parallel_lmdz
+  USE infotrac
+#ifdef CPP_PHYS
+  USE mod_interface_dyn_phys, ONLY: init_interface_dyn_phys
+#endif
+  USE mod_hallo
+  USE Bands
+  USE filtreg_mod
+  USE control_mod
+
+#ifdef INCA
+  ! Only INCA needs these informations (from the Earth's physics)
+  USE indice_sol_mod
+  USE mod_phys_lmdz_omp_data, ONLY: klon_omp 
+#endif
+
+#ifdef CPP_PHYS
+  !      USE mod_grid_phy_lmdz
+  !      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+  !      USE dimphy
+  !      USE comgeomphy
+#endif
+  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 "comconst.h"
+  include "comdissnew.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "logic.h"
+  include "temps.h"
+  include "ener.h"
+  include "description.h"
+  include "serre.h"
+  !include "com_io_dyn.h"
+  include "iniprint.h"
+  include "tracstoke.h"
+
+#ifdef INCA
+  ! Only INCA needs these informations (from the Earth's physics)
+  !include "indicesol.h"
+#endif
+
+  REAL zdtvr
+
+  !   variables dynamiques
+  REAL,ALLOCATABLE,SAVE  :: vcov(:,:),ucov(:,:) ! vents covariants
+  REAL,ALLOCATABLE,SAVE  :: teta(:,:)     ! temperature potentielle 
+  REAL, ALLOCATABLE,SAVE :: q(:,:,:)      ! champs advectes
+  REAL,ALLOCATABLE,SAVE  :: ps(:)         ! pression  au sol
+  !      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+  REAL,ALLOCATABLE,SAVE  :: masse(:,:)    ! masse d'air
+  REAL,ALLOCATABLE,SAVE  :: phis(:)       ! 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
+
+  !+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
+
+
+  !-----------------------------------------------------------------------
+  !   Initialisations:
+  !   ----------------
+
+  abort_message = 'last timestep reached'
+  modname = 'gcm'
+  descript = 'Run GCM LMDZ'
+  lafin    = .FALSE.
+  dynhist_file = 'dyn_hist'
+  dynhistave_file = 'dyn_hist_ave'
+
+
+
+  !----------------------------------------------------------------------
+  !  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)
+  !
+  !
+  !------------------------------------
+  !   Initialisation partie parallele
+  !------------------------------------
+  CALL init_const_mpi
+
+  call init_parallel
+  call Read_Distrib
+
+#ifdef CPP_PHYS
+  CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
+  !#endif
+  !      CALL set_bands
+  !#ifdef CPP_PHYS
+  CALL Init_interface_dyn_phys
+#endif
+  CALL barrier
+
+  CALL set_bands
+  if (mpi_rank==0) call WriteBands
+  call Set_Distrib(distrib_caldyn)
+
+  !$OMP PARALLEL
+  call Init_Mod_hallo
+  !$OMP END PARALLEL
+
+  !#ifdef CPP_PHYS
+  !c$OMP PARALLEL
+  !      call InitComgeomphy ! now done in iniphysiq
+  !c$OMP END PARALLEL 
+  !#endif
+
+  !-----------------------------------------------------------------------
+  !   Choix du calendrier
+  !   -------------------
+
+  !      calend = 'earth_365d'
+
+#ifdef CPP_IOIPSL
+  if (calend == 'earth_360d') then
+     call ioconf_calendar('360d')
+     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
+#endif
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+     call init_const_lmdz( &
+          nbtr,anneeref,dayref, &
+          iphysiq,day_step,nday,  &
+          nbsrf, is_oce,is_sic, &
+          is_ter,is_lic, calend)
+
+     call init_inca_para( &
+          iim,jjm+1,llm,klon_glo,mpi_size, &
+          distrib_phys,COMM_LMDZ)
+#endif
+  END IF
+
+  !-----------------------------------------------------------------------
+  !   Initialisation des traceurs
+  !   ---------------------------
+  !  Choix du nombre de traceurs et du schema pour l'advection
+  !  dans fichier traceur.def, par default ou via INCA
+  call infotrac_init
+
+  ! Allocation de la tableau q : champs advectes   
+  ALLOCATE(ucov(ijb_u:ije_u,llm))
+  ALLOCATE(vcov(ijb_v:ije_v,llm))
+  ALLOCATE(teta(ijb_u:ije_u,llm))
+  ALLOCATE(masse(ijb_u:ije_u,llm))
+  ALLOCATE(ps(ijb_u:ije_u))
+  ALLOCATE(phis(ijb_u:ije_u))
+  ALLOCATE(q(ijb_u:ije_u,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_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
+     endif
+
+     !        if (planet_type.eq."earth") then
+     ! Load an Earth-format start file
+     CALL dynetat0_loc("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
+     CALL iniacademic_loc(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
+        WRITE(lunout,*)'Je m''arrete'
+        CALL abort
+     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
+
+#ifdef CPP_IOIPSL
+  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
+#else
+  ! Ehouarn: we still need to define JD_ref and JH_ref
+  ! and since we don't know how many days there are in a year
+  ! we set JD_ref to 0 (this should be improved ...)
+  jD_ref=0
+  jH_ref=0
+#endif
+
+  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)
+
+  !-----------------------------------------------------------------------
+  !   Initialisation de la physique :
+  !   -------------------------------
+  IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
+     ! Physics:
+#ifdef CPP_PHYS
+     CALL iniphysiq(iim,jjm,llm,daysec,day_ini,dtphys/nsplit_phys, &
+          rlatu,rlonv,aire,cu,cv,rad,g,r,cpp, &
+          iflag_phys)
+#endif
+  ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
+
+
+  !-----------------------------------------------------------------------
+  !   Initialisation des dimensions d'INCA :
+  !   --------------------------------------
+  IF (type_trac == 'inca') THEN
+     !$OMP PARALLEL
+#ifdef INCA
+     CALL init_inca_dim(klon_omp,llm,iim,jjm, &
+          rlonu,rlatu,rlonv,rlatv)
+#endif
+     !$OMP END PARALLEL
+  END IF
+
+  !-----------------------------------------------------------------------
+  !   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//)
+
+#ifdef CPP_IOIPSL
+  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)
+#endif
+
+  !      if (planet_type.eq."earth") then
+  ! Write an Earth-format restart file
+  CALL dynredem0_loc("restart.nc", day_end, phis)
+  !      endif
+
+  ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+  time_step = zdtvr
+  IF (mpi_rank==0) then
+     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
+        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_loc(day_ref,annee_ref,time_step,t_ops,t_wrt)
+     END IF
+  ENDIF
+  dtav = iperiod*dtvr/daysec
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+
+  !  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
+
+  !$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logici/,/logicl/)
+  CALL leapfrog_loc(ucov,vcov,teta,ps,masse,phis,q,time_0)
+  !$OMP END PARALLEL
+
+  !      OPEN(unit=5487,file='ok_lmdz',status='replace')
+  !      WRITE(5487,*) 'ok_lmdz'
+  !      CLOSE(5487)
+END PROGRAM gcm
Index: LMDZ5/branches/testing/libf/dyn3dmem/gr_dyn_fi_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/gr_dyn_fi_p.F	(revision 2274)
+++ 	(revision )
@@ -1,44 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-      USE mod_interface_dyn_phys
-      USE dimphy
-      USE parallel_lmdz
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ig,l
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-c      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
-c   traitement des poles
-c   traitement des point normaux
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,nfield    
-       DO ig=1,klon
-         i=index_i(ig)
-         j=index_j(ig)
-         pfi(ig,l)=pdyn(i,j,l)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-#endif
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dmem/gr_fi_dyn_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/gr_fi_dyn_p.F	(revision 2274)
+++ 	(revision )
@@ -1,56 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-      USE mod_interface_dyn_phys
-      USE dimphy
-      USE parallel_lmdz
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO ifield=1,nfield
-
-        do ig=1,klon
-          i=index_i(ig)
-          j=index_j(ig)
-          pdyn(i,j,ifield)=pfi(ig,ifield)
-          if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield)
-	enddo
-
-c   traitement des poles
-      if (pole_nord) then
-        do i=1,im
-	  pdyn(i,1,ifield)=pdyn(1,1,ifield)
-	enddo
-      endif
-       
-      if (pole_sud) then
-        do i=1,im
-	  pdyn(i,jm,ifield)=pdyn(1,jm,ifield)
-	enddo
-      endif
-      
-      ENDDO
-c$OMP END DO NOWAIT
-#endif
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dmem/guide_loc_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/guide_loc_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/guide_loc_mod.F90	(revision 2298)
@@ -87,4 +87,5 @@
 ! Lecture des parametres:  
 ! ---------------------------------------------
+    call ini_getparam("nudging_parameters_out.txt")
 ! Variables guidees
     CALL getpar('guide_u',.true.,guide_u,'guidage de u')
@@ -159,4 +160,6 @@
     CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
 
+    call fin_getparam
+    
 ! ---------------------------------------------
 ! Determination du nombre de niveaux verticaux
Index: LMDZ5/branches/testing/libf/dyn3dmem/iniacademic_loc.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/iniacademic_loc.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/iniacademic_loc.F90	(revision 2298)
@@ -7,5 +7,6 @@
   use exner_hyb_m, only: exner_hyb
   use exner_milieu_m, only: exner_milieu
-  USE infotrac, ONLY : nqtot
+  USE infotrac, ONLY: nqtot,niso_possibles,ok_isotopes,iqpere,ok_iso_verif,tnat,alpha_ideal, &
+        & iqiso,phase_num,iso_indnum,iso_num,zone_num
   USE control_mod, ONLY: day_step,planet_type
   USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
@@ -110,5 +111,5 @@
   ztot0      = 0.
   stot0      = 0.
-  ang0       = 0.
+  ang0       = 0.      
 
   if (llm == 1) then
@@ -269,12 +270,32 @@
         if (planet_type=="earth") then
            ! Earth: first two tracers will be water
+
            do i=1,nqtot
               if (i == 1) q(ijb_u:ije_u,:,i)=1.e-10
               if (i == 2) q(ijb_u:ije_u,:,i)=1.e-15
               if (i.gt.2) q(ijb_u:ije_u,:,i)=0.
+
+              ! CRisi: init des isotopes
+              ! distill de Rayleigh très simplifiée
+              if (ok_isotopes) then
+                if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then          
+                   q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqpere(i))       &
+      &                  *tnat(iso_num(i))                             &
+      &                  *(q(ijb_u:ije_u,:,iqpere(i))/30.e-3)                              &
+     &                   **(alpha_ideal(iso_num(i))-1)
+                endif                
+                if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
+                  q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqiso(iso_indnum(i),phase_num(i)))
+                endif
+              endif !if (ok_isotopes) then
+
            enddo
         else
            q(ijb_u:ije_u,:,:)=0
         endif ! of if (planet_type=="earth")
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
+        endif !if (ok_iso_verif) then
 
         ! add random perturbation to temperature
Index: LMDZ5/branches/testing/libf/dyn3dmem/integrd_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/integrd_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/integrd_loc.F	(revision 2298)
@@ -11,4 +11,5 @@
       USE write_field
       USE integrd_mod
+      USE infotrac, ONLY: ok_iso_verif ! ajout CRisi
       IMPLICIT NONE
 
@@ -86,5 +87,7 @@
       INTEGER :: ierr
 
+      !write(*,*) 'integrd 88: entree, nq=',nq
 c-----------------------------------------------------------------------
+
 c$OMP BARRIER     
       if (pole_nord) THEN
@@ -125,6 +128,8 @@
       DO 2 ij = ijb,ije
        pscr (ij)    = ps0(ij)
-       ps (ij)      = psm1(ij) + dt * dp(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)     
+
    2  CONTINUE
+
 c$OMP END DO  
 c$OMP BARRIER
@@ -159,4 +164,5 @@
 c$OMP END MASTER
 c$OMP BARRIER
+        !write(*,*) 'integrd 170'
       IF (.NOT. Checksum_all) THEN
         call WriteField_v('int_vcov',vcov)
@@ -188,4 +194,5 @@
        
 c
+        !write(*,*) 'integrd 200'
 C$OMP MASTER
       if (pole_nord) THEN
@@ -214,4 +221,5 @@
 c$OMP END MASTER
 c$OMP BARRIER
+      !write(*,*) 'integrd 217'  
 c
 c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
@@ -219,4 +227,5 @@
 
       CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
+
 c$OMP BARRIER
       CALL massdair_loc (     p  , masse         )
@@ -276,4 +285,5 @@
 c
 c
+        !write(*,*) 'integrd 291'
       IF (pole_nord) THEN
        
@@ -334,8 +344,19 @@
            ENDDO
           ENDDO
+          
 c$OMP END DO NOWAIT
 c$OMP BARRIER
 
-          CALL qminimum_loc( q, nq, deltap )
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb,ije,'integrd 342')
+        endif !if (ok_iso_verif) then
+
+        !write(*,*) 'integrd 341'
+        CALL qminimum_loc( q, nq, deltap )
+        !write(*,*) 'integrd 343'
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb,ije,'integrd 346')
+        endif !if (ok_iso_verif) then
 c
 c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
@@ -387,4 +408,8 @@
       
       ENDIF
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb,ije,'integrd 409')
+        endif !if (ok_iso_verif) then
       
 ! Ehouarn: forget about finvmaold
@@ -404,4 +429,5 @@
 
 15    continue
+          !write(*,*) 'integrd 410'
 
 c$OMP DO SCHEDULE(STATIC)
Index: LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_loc.F	(revision 2298)
@@ -200,4 +200,8 @@
       LOGICAL, SAVE :: firstcall=.TRUE.
       TYPE(distrib),SAVE :: new_dist
+
+      if (ok_iso_verif) then
+         call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
+      endif !if (ok_iso_verif) then
       
 c$OMP MASTER
@@ -219,4 +223,8 @@
       itaufinp1 = itaufin +1
 
+      if (ok_iso_verif) then
+        call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
+      endif !if (ok_iso_verif) then
+
       itau = 0
       physic=.true.
@@ -231,4 +239,8 @@
       phis=phis0
       q=q0
+
+      if (ok_iso_verif) then
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
+      endif !if (ok_iso_verif) then
       
 !      iday = day_ini+itau/day_step
@@ -296,5 +308,5 @@
 
    1  CONTINUE ! Matsuno Forward step begins here
-
+      !write(*,*) 'leapfrog 298: itau=',itau
       jD_cur = jD_ref + day_ini - day_ref +                             &
      &          itau/day_step
@@ -306,4 +318,7 @@
       endif
 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
+        endif !if (ok_iso_verif) then
 
 #ifdef CPP_IOIPSL
@@ -384,5 +399,15 @@
 cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
 
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
+        endif !if (ok_iso_verif) then
+
    2  CONTINUE ! Matsuno backward or leapfrog step begins here
+
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
+        endif !if (ok_iso_verif) then
 
 c$OMP MASTER
@@ -455,4 +480,8 @@
 c$OMP END MASTER      
 
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
+        endif !if (ok_iso_verif) then
 
 !ym  PAS D'AJUSTEMENT POUR LE MOMENT     
@@ -574,4 +603,7 @@
      
       
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
+        endif !if (ok_iso_verif) then
       
 c-----------------------------------------------------------------------
@@ -635,5 +667,8 @@
       ! compute geopotential phi()
       CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
-
+        
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
+        endif !if (ok_iso_verif) then
       
       call VTb(VTcaldyn)
@@ -644,4 +679,5 @@
 !      CALL FTRACE_REGION_BEGIN("caldyn")
       time = jD_cur + jH_cur 
+
       CALL caldyn_loc 
      $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
@@ -670,10 +706,21 @@
 c   -------------------------------------------------------------
 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,
+     &           'leapfrog 686: avant caladvtrac')
+        endif !if (ok_iso_verif) then
       
       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)
+
+         !write(*,*) 'leapfrog 719'
+         if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,
+     &           'leapfrog 698: apres caladvtrac')
+         endif !if (ok_iso_verif) then
 
 !      do j=1,nqtot
@@ -708,8 +755,19 @@
 !       CALL FTRACE_REGION_BEGIN("integrd")
 
-       CALL integrd_loc ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+       !write(*,*) 'leapfrog 720' 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
+        endif !if (ok_iso_verif) then
+
+       ! 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'       
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
+        endif !if (ok_iso_verif) then 
+ 
 !       CALL FTRACE_REGION_END("integrd")
 c$OMP BARRIER
@@ -724,4 +782,9 @@
       call WriteField_u('ps_int',ps)
 #endif    
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
+        endif !if (ok_iso_verif) then
+
 c      do j=1,nqtot
 c        call WriteField_p('q'//trim(int2str(j)),
@@ -1082,4 +1145,9 @@
        ENDIF ! of IF( apphys )
 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
+        endif !if (ok_iso_verif) then
+        !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
+
       IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
 c$OMP MASTER
@@ -1146,9 +1214,12 @@
 
 cc$OMP END PARALLEL
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
+        endif !if (ok_iso_verif) then
 
 c-----------------------------------------------------------------------
 c   dissipation horizontale et verticale  des petites echelles:
 c   ----------------------------------------------------------
-
+      !write(*,*) 'leapfrog 1163: apdiss=',apdiss
       IF(apdiss) THEN
       
@@ -1379,5 +1450,9 @@
 c                call abort_gcm(modname,abort_message,0)
 c              ENDIF
-        
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
+        endif !if (ok_iso_verif) then     
+ 
 c   ********************************************************************
 c   ********************************************************************
@@ -1455,4 +1530,8 @@
       ENDIF
       
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
+        endif !if (ok_iso_verif) then
+
       IF ( .NOT.purmats ) THEN
 c       ........................................................
@@ -1526,4 +1605,8 @@
             ENDIF
 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
+        endif !if (ok_iso_verif) then
+
 c-----------------------------------------------------------------------
 c   ecriture de la bande histoire:
@@ -1562,4 +1645,8 @@
             ENDIF ! of IF (itau.EQ.itaufin)
 
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
+        endif !if (ok_iso_verif) then
+
 c-----------------------------------------------------------------------
 c   gestion de l'integration temporelle:
@@ -1596,4 +1683,9 @@
 
       ELSE ! of IF (.not.purmats)
+
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
+        endif !if (ok_iso_verif) then
 
 c       ........................................................
@@ -1631,4 +1723,9 @@
 
             ELSE ! of IF(forward) i.e. backward step
+
+              
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
+        endif !if (ok_iso_verif) then  
 
               IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
@@ -1683,4 +1780,9 @@
             ENDIF ! of IF (forward)
 
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
+        endif !if (ok_iso_verif) then
+
       END IF ! of IF(.not.purmats)
 c$OMP MASTER
Index: LMDZ5/branches/testing/libf/dyn3dmem/mod_interface_dyn_phys.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/mod_interface_dyn_phys.F90	(revision 2274)
+++ 	(revision )
@@ -1,58 +1,0 @@
-! 
-! $Id$
-!
-MODULE mod_interface_dyn_phys
-  INTEGER,SAVE,dimension(:),allocatable :: index_i
-  INTEGER,SAVE,dimension(:),allocatable :: index_j
-  
-  
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-CONTAINS
-  
-  SUBROUTINE Init_interface_dyn_phys
-    USE mod_phys_lmdz_mpi_data
-    IMPLICIT NONE
-    include 'dimensions.h'    
-    
-    INTEGER :: i,j,k
-    
-    ALLOCATE(index_i(klon_mpi))
-    ALLOCATE(index_j(klon_mpi))
-    
-    k=1
-    IF (is_north_pole) THEN
-      index_i(k)=1
-      index_j(k)=1
-      k=2
-    ELSE
-      DO i=ii_begin,iim
-	index_i(k)=i
-	index_j(k)=jj_begin
-	k=k+1
-       ENDDO
-    ENDIF
-    
-    DO j=jj_begin+1,jj_end-1
-      DO i=1,iim
-	index_i(k)=i
-	index_j(k)=j
-	k=k+1
-      ENDDO
-    ENDDO
-    
-    IF (is_south_pole) THEN
-      index_i(k)=1
-      index_j(k)=jj_end
-    ELSE
-      DO i=1,ii_end
-	index_i(k)=i
-	index_j(k)=jj_end
-	k=k+1
-       ENDDO
-    ENDIF
-  
-  END SUBROUTINE Init_interface_dyn_phys 
-#endif
-! of #ifdef CPP_PHYS
-END MODULE mod_interface_dyn_phys
Index: LMDZ5/branches/testing/libf/dyn3dmem/qminimum_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/qminimum_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/qminimum_loc.F	(revision 2298)
@@ -1,4 +1,5 @@
-      SUBROUTINE qminimum_loc( q,nq,deltap )
+      SUBROUTINE qminimum_loc( q,nqtot,deltap )
       USE parallel_lmdz
+      USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
       IMPLICIT none
 c
@@ -10,6 +11,6 @@
 #include "comvert.h"
 c
-      INTEGER nq
-      REAL q(ijb_u:ije_u,llm,nq), deltap(ijb_u:ije_u,llm)
+      INTEGER nqtot ! CRisi: on remplace nq par nqtot
+      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
 c
       INTEGER iq_vap, iq_liq
@@ -27,4 +28,7 @@
       INTEGER i, k, iq
       REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+
+      real zx_defau_diag(ijb_u:ije_u,llm,2) 
+      real q_follow(ijb_u:ije_u,llm,2) 
 c
       REAL SSUM
@@ -38,4 +42,6 @@
       INTEGER Index_pump(ij_end-ij_begin+1)
       INTEGER nb_pump
+      INTEGER ixt
+      INTEGER iso_verif_noNaN_nostop
 c
 c Quand l'eau liquide est trop petite (ou negative), on prend
@@ -44,11 +50,26 @@
 c
 
+        !write(*,*) 'qminimum 52: entree'
+        if (ok_iso_verif) then
+           call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
+        endif !if (ok_iso_verif) then     
+
       ijb=ij_begin
       ije=ij_end
 
+      zx_defau_diag(ijb:ije,:,:)=0.0
+      q_follow(ijb:ije,:,1:2)=q(ijb:ije,:,1:2)  
+
+      !write(*,*) 'qminimum 57'
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
       DO 1000 k = 1, llm
       DO 1040 i = ijb, ije
             if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+
+              if (ok_isotopes) then
+                 zx_defau_diag(i,k,iq_liq)=AMAX1
+     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
+              endif !if (ok_isotopes) then
+
                q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
                q(i,k,iq_liq) = seuil_liq
@@ -60,8 +81,10 @@
 c --->  SYNCHRO OPENMP ICI
 
+
 c
 c Quand l'eau vapeur est trop faible (ou negative), on complete
 c le defaut en prennant de l'eau vapeur de la couche au-dessous.
 c
+      !write(*,*) 'qminimum 81'
       iq = iq_vap
 c
@@ -70,8 +93,15 @@
 c$OMP DO SCHEDULE(STATIC)
       DO i = ijb, ije
+
          if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
+
+            if (ok_isotopes) then
+              zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+            endif !if (ok_isotopes) then
+
             q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
      &           deltap(i,k) / deltap(i,k-1)
             q(i,k,iq)   =  seuil_vap  
+
          endif
       ENDDO
@@ -79,8 +109,10 @@
       ENDDO
 c$OMP BARRIER
+
 c
 c Quand il s'agit de la premiere couche au-dessus du sol, on
 c doit imprimer un message d'avertissement (saturation possible).
 c
+      !write(*,*) 'qminimum 106'
       nb_pump=0
 c$OMP DO SCHEDULE(STATIC)
@@ -103,4 +135,114 @@
          ENDDO
       ENDIF
+
+      !write(*,*) 'qminimum 128'
+      if (ok_isotopes) then
+      ! CRisi: traiter de même les traceurs d'eau
+      ! Mais il faut les prendre à l'envers pour essayer de conserver la
+      ! masse.
+      ! 1) pompage dans le sol  
+      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+      ! rien ici et on croise les doigts pour que ça ne soit pas trop
+      ! génant
+      DO i = ijb, ije
+        if (zx_pump(i).gt.0.0) then
+          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
+        endif !if (zx_pump(i).gt.0.0) then
+      enddo !DO i = ijb, ije  
+
+      ! 2) transfert de vap vers les couches plus hautes
+      !write(*,*) 'qminimum 139'
+      do k=2,llm
+        DO i = ijb, ije
+          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
+              ! on ajoute la vapeur en k              
+              do ixt=1,ntraciso
+               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
+     :              +zx_defau_diag(i,k,iq_vap)
+     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+                
+              if (ok_iso_verif) then
+                if (iso_verif_noNaN_nostop(q(i,k,iqiso(ixt,iq_vap)),
+     :                   'qminimum 155').eq.1) then
+                   write(*,*) 'i,k,ixt=',i,k,ixt
+                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
+     :                   q_follow(i,k-1,iq_vap)
+                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
+     :                   q(i,k,iqiso(ixt,iq_vap))
+                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
+     :                   zx_defau_diag(i,k,iq_vap)
+                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
+     :                   q(i,k-1,iqiso(ixt,iq_vap))
+                   stop
+                endif
+              endif
+
+              ! et on la retranche en k-1
+               q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,iq_vap)
+     :              *deltap(i,k)/deltap(i,k-1)
+     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+
+               if (ok_iso_verif) then
+                if (iso_verif_noNaN_nostop(q(i,k-1,iqiso(ixt,iq_vap)),
+     :                   'qminimum 175').eq.1) then
+                   write(*,*) 'k,i,ixt=',k,i,ixt
+                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
+     :                   q_follow(i,k-1,iq_vap)
+                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
+     :                   q(i,k,iqiso(ixt,iq_vap))
+                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
+     :                   zx_defau_diag(i,k,iq_vap)
+                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
+     :                   q(i,k-1,iqiso(ixt,iq_vap))
+                   stop
+                endif
+              endif 
+
+              enddo !do ixt=1,niso
+              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
+     :               +zx_defau_diag(i,k,iq_vap)
+              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
+     :               -zx_defau_diag(i,k,iq_vap)
+     :              *deltap(i,k)/deltap(i,k-1)
+          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+        enddo !DO i = 1, ip1jmp1        
+       enddo !do k=2,llm
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb,ije,'qminimum 168')
+        endif !if (ok_iso_verif) then
+        
+      
+        ! 3) transfert d'eau de la vapeur au liquide
+        !write(*,*) 'qminimum 164'
+        do k=1,llm
+        DO i = ijb, ije
+          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
+
+              ! on ajoute eau liquide en k en k              
+              do ixt=1,ntraciso
+               q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
+     :              +zx_defau_diag(i,k,iq_liq)
+     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
+              ! et on la retranche à la vapeur en k
+               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,iq_liq)
+     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
+              enddo !do ixt=1,niso
+              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
+     :               +zx_defau_diag(i,k,iq_liq)
+              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
+     :               -zx_defau_diag(i,k,iq_liq)
+          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+        enddo !DO i = 1, ip1jmp1
+       enddo !do k=2,llm  
+
+        if (ok_iso_verif) then
+           call check_isotopes(q,ijb,ije,'qminimum 197')
+        endif !if (ok_iso_verif) then
+
+      endif !if (ok_isotopes) then
+      !write(*,*) 'qminimum 188'
 c
       RETURN
Index: LMDZ5/branches/testing/libf/dyn3dmem/vlsplt_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/vlsplt_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/vlsplt_loc.F	(revision 2298)
@@ -2,5 +2,5 @@
 ! $Id$
 !
-      SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x)
+      RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq)
 
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -14,4 +14,5 @@
 c   --------------------------------------------------------------------
       USE parallel_lmdz
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
       IMPLICIT NONE
 c
@@ -25,8 +26,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ijb_u:ije_u,llm),pente_max
-      REAL u_m( ijb_u:ije_u,llm ),pbarv( iip1,jjb_v:jje_v,llm)
-      REAL q(ijb_u:ije_u,llm)
-      REAL w(ijb_u:ije_u,llm)
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
+      REAL u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot
+      REAL w(ijb_u:ije_u,llm) 
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -42,4 +44,7 @@
       REAL u_mq(ijb_u:ije_u,llm)
 
+      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
+
       Logical extremum
 
@@ -51,4 +56,6 @@
       INTEGER ijb,ije,ijb_x,ije_x
       
+      !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
+!     &   iq,ijb_x
 c   calcul de la pente a droite et a gauche de la maille
 
@@ -64,5 +71,5 @@
 c   calcul des pentes avec limitation, Van Leer scheme I:
 c   -----------------------------------------------------
-
+      ! on a besoin de q entre ijb et ije
 c   calcul de la pente aux points u
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
@@ -70,7 +77,7 @@
             
             DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
 c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
-c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
@@ -126,5 +133,5 @@
          DO l = 1, llm
             DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
@@ -147,4 +154,6 @@
       ENDIF ! (pente_max.lt.-1.e-5)
 
+      !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
+
 c   bouclage de la pente en iip1:
 c   -----------------------------
@@ -168,11 +177,11 @@
       DO l=1,llm
        DO ij=ijb,ije-1
-          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
-     ,                     1.+u_m(ij,l)/masse(ij+1,l),
-     ,                     u_m(ij,l))
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
+     ,                     u_m(ij,l,iq))
           zdum(ij,l)=0.5*zdum(ij,l)
           u_mq(ij,l)=cvmgp(
-     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
-     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
      ,                u_m(ij,l))
           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
@@ -185,13 +194,16 @@
 c	print*,'Cumule ....'
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        ! on a besoin de masse entre ijb et ije
       DO l=1,llm
        DO ij=ijb,ije-1
-c	print*,'masse(',ij,')=',masse(ij,l)
+c	print*,'masse(',ij,')=',masse(ij,l,iq)
           IF (u_m(ij,l).gt.0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)
+     :           +0.5*zdum(ij,l)*dxq(ij,l))
           ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
+     :           -0.5*zdum(ij,l)*dxq(ij+1,l))
           ENDIF
        ENDDO
@@ -215,4 +227,5 @@
 c$OMP END DO NOWAIT
 c	print*,'Ok test 1'
+
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
@@ -223,5 +236,5 @@
 c$OMP END DO NOWAIT
 c	 print*,'Ok test 2'
-
+        
 
 c   traitement special pour le cas ou on advecte en longitude plus que le
@@ -247,4 +260,6 @@
 c     &       ,'contenu de la maille : ',n0
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+
+
          DO l=1,llm
             IF(nl(l).gt.0) THEN
@@ -258,5 +273,5 @@
                ENDDO
                niju=iju
-c              PRINT*,'niju,nl',niju,nl(l)
+               !PRINT*,'vlx 278, niju,nl',niju,nl(l)
 
 c  traitement des mailles
@@ -270,7 +285,8 @@
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m-masse(ijq,l)
+                     do while(zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)
+     &                          +q(ijq,l,iq)*masse(ijq,l,iq)
+                        zu_m=zu_m-masse(ijq,l,iq)
                         i=mod(i-2+iim,iim)+1
                         ijq=(j-1)*iip1+i
@@ -278,18 +294,20 @@
 c   ajout de la maille non completement advectee
                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
-     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+     &               (q(ijq,l,iq)+0.5*
+     &               (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ELSE
                      ijq=ij+1
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(-zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m+masse(ijq,l)
+                     do while(-zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
+     &                           *masse(ijq,l,iq)
+                        zu_m=zu_m+masse(ijq,l,iq)
                         i=mod(i,iim)+1
                         ijq=(j-1)*iip1+i
                      ENDDO
 c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
-     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
+     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ENDIF
                ENDDO
@@ -299,5 +317,4 @@
 cym      ENDIF  ! n0.gt.0 
 9999    continue
-
 
 c   bouclage en latitude
@@ -311,21 +328,71 @@
 c$OMP END DO NOWAIT
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+
+      !write(*,*) 'vlsplt 326: iq,ijb_x,nqfils(iq)=',iq,ijb_x,nqfils(iq) 
+
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+          DO ij=ijb,ije
+           ! On a besoin de q et masse seulement entre ijb et ije. On ne
+           ! les calcule donc que de ijb à ije
+           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+          enddo   
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi
+
+      !write(*,*) 'vlsplt 360: iq,ijb_x=',iq,ijb_x
+
 c   calcul des tENDances
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          DO ij=ijb+1,ije
-            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+
-     &      u_mq(ij-1,l)-u_mq(ij,l))
-     &      /new_m
-            masse(ij,l)=new_m
+            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
+     &        u_mq(ij-1,l)-u_mq(ij,l))
+     &        /new_m
+            masse(ij,l,iq)=new_m
          ENDDO
 c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
          DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l)=q(ij,l)
-            masse(ij-iim,l)=masse(ij,l)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
+            q(ij-iim,l,iq)=q(ij,l,iq)
+            masse(ij-iim,l,iq)=masse(ij,l,iq)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      !write(*,*) 'vlsplt 380: iq,ijb_x=',iq,ijb_x
+
+! retablir les fils en rapport de melange par rapport a l'air:
+      ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio 
+      ! puis on boucle en longitude
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb+1,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+          DO ij=ijb+iip1-1,ije,iip1
+             q(ij-iim,l,iq2)=q(ij,l,iq2)
+          enddo ! DO ij=ijb+iip1-1,ije,iip1
+         enddo !DO l=1,llm
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+      !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
@@ -336,5 +403,5 @@
 
 
-      SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v)
+      RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq)
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -349,4 +416,5 @@
 c   --------------------------------------------------------------------
       USE parallel_lmdz
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
       IMPLICIT NONE
 c
@@ -361,7 +429,8 @@
 c   Arguments:
 c   ----------
-      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
       REAL masse_adv_v( ijb_v:ije_v,llm)
-      REAL q(ijb_u:ije_u,llm), dq( ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -392,4 +461,7 @@
       SAVE airej2,airejjm
 c$OMP THREADPRIVATE(airej2,airejjm)
+
+      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
 c
 c
@@ -401,6 +473,11 @@
       INTEGER ijb,ije
 
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1  
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+
       IF(first) THEN
-c         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
          first=.false.
          do i=2,iip1
@@ -434,5 +511,5 @@
       if (pole_nord) then
         DO i = 1, iim
-          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
         ENDDO
         qpns   = SSUM( iim,  airescb ,1 ) / airej2
@@ -441,11 +518,9 @@
       if (pole_sud) then
         DO i = 1, iim
-          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
         ENDDO
         qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
       endif
       
-      
-
 c   calcul des pentes aux points v
 
@@ -455,8 +530,12 @@
       if (pole_sud)  ije=ij_end-iip1
       
+      ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
+      ! Si pole sud, entre ij_begin-2*iip1 et ij_end
+      ! Si pole Nord, entre ij_begin et ij_end+2*iip1
       DO ij=ijb,ije
-         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
          adyqv(ij)=abs(dyqv(ij))
       ENDDO
+ 
 
 c   calcul des pentes aux points scalaires
@@ -475,5 +554,5 @@
       IF (pole_nord) THEN
         DO ij=1,iip1
-           dyq(ij,l)=qpns-q(ij+iip1,l)
+           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
         ENDDO
         
@@ -497,5 +576,5 @@
 
         DO ij=1,iip1
-           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
         ENDDO
 
@@ -633,9 +712,10 @@
        DO ij=ijb,ije
           IF(masse_adv_v(ij,l).gt.0) THEN
-              qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
-     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+              qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)
+     ,                   /masse(ij+iip1,l,iq))
           ELSE
-              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+              qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq))
           ENDIF
           qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
@@ -643,4 +723,33 @@
       ENDDO
 c$OMP END DO NOWAIT
+
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq) 
+
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+   
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l=1,llm
+         DO ij=ijb,ije
+           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
+          enddo   
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi
       
       ijb=ij_begin
@@ -652,11 +761,15 @@
       DO l=1,llm
          DO ij=ijb,ije
-            newmasse=masse(ij,l)
-     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-     
-            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
-     &         /newmasse
-            masse(ij,l)=newmasse
-         ENDDO
+            newmasse=masse(ij,l,iq)
+     &         +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
+     &         -qbyv(ij-iip1,l))/newmasse
+
+            masse(ij,l,iq)=newmasse
+
+         ENDDO
+
+
 c.-. ancienne version
 c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
@@ -665,12 +778,12 @@
            convpn=SSUM(iim,qbyv(1,l),1)
            convmpn=ssum(iim,masse_adv_v(1,l),1)
-           massepn=ssum(iim,masse(1,l),1)
+           massepn=ssum(iim,masse(1,l,iq),1)
            qpn=0.
            do ij=1,iim
-              qpn=qpn+masse(ij,l)*q(ij,l)
+              qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
            enddo
            qpn=(qpn+convpn)/(massepn+convmpn)
            do ij=1,iip1
-              q(ij,l)=qpn
+              q(ij,l,iq)=qpn
            enddo
          endif
@@ -683,12 +796,12 @@
            convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
            convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-           masseps=ssum(iim, masse(ip1jm+1,l),1)
+           masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
            qps=0.
            do ij = ip1jm+1,ip1jmp1-1
-              qps=qps+masse(ij,l)*q(ij,l)
+              qps=qps+masse(ij,l,iq)*q(ij,l,iq)
            enddo
            qps=(qps+convps)/(masseps+convmps)
            do ij=ip1jm+1,ip1jmp1
-              q(ij,l)=qps
+              q(ij,l,iq)=qps
            enddo
          endif
@@ -704,5 +817,5 @@
 c        DO ij = 1,iip1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
@@ -714,5 +827,5 @@
 c        DO ij = ip1jm+1,ip1jmp1
 c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c._. fin nouvelle version
@@ -720,4 +833,24 @@
 c$OMP END DO NOWAIT
 
+! retablir les fils en rapport de melange par rapport a l'air:
+      ijb=ij_begin
+      ije=ij_end
+!      if (pole_nord) ijb=ij_begin
+!      if (pole_sud)  ije=ij_end
+
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+
       RETURN
       END
@@ -725,5 +858,5 @@
       
       
-      SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x)
+      RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq)
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -739,4 +872,5 @@
       USE parallel_lmdz
       USE vlz_mod
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi  
       IMPLICIT NONE
 c
@@ -750,7 +884,8 @@
 c   Arguments:
 c   ----------
-      REAL masse(ijb_u:ije_u,llm),pente_max
-      REAL q(ijb_u:ije_u,llm)
-      REAL w(ijb_u:ije_u,llm+1)
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
+      REAL q(ijb_u:ije_u,llm,nqtot)
+      REAL w(ijb_u:ije_u,llm+1,nqtot)
+      INTEGER iq
 c
 c      Local 
@@ -779,5 +914,9 @@
       LOGICAL,SAVE :: first=.TRUE.
 !$OMP THREADPRIVATE(first)
-      
+
+      !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      ! Ces varibles doivent être déclarées en pointer et en save dans
+      ! vlz_loc si on veut qu'elles soient vues par tous les threads.  
+      INTEGER ifils,iq2 ! CRisi
 
       IF (first) THEN
@@ -787,4 +926,5 @@
 c    sens de W
 
+      !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
 #ifdef BIDON
       IF(testcpu) THEN
@@ -799,5 +939,5 @@
       DO l=2,llm
          DO ij=ijb,ije
-            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
             adzqw(ij,l)=abs(dzqw(ij,l))
          ENDDO
@@ -842,37 +982,86 @@
 c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
 
+       !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        DO l = 1,llm-1
          do  ij = ijb,ije
-          IF(w(ij,l+1).gt.0.) THEN
-             sigw=w(ij,l+1)/masse(ij,l+1)
-             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+          IF(w(ij,l+1,iq).gt.0.) THEN
+             sigw=w(ij,l+1,iq)/masse(ij,l+1,iq)
+             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq)
+     :           +0.5*(1.-sigw)*dzq(ij,l+1))
           ELSE
-             sigw=w(ij,l+1)/masse(ij,l)
-             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+             sigw=w(ij,l+1,iq)/masse(ij,l,iq)
+             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq)
+     :           -0.5*(1.+sigw)*dzq(ij,l))
           ENDIF
          ENDDO
        ENDDO
-c$OMP END DO NOWAIT
+c$OMP END DO NOWAIT    
+       !write(*,*) 'vlz 1001'    
 
 c$OMP MASTER
        DO ij=ijb,ije
-          wq(ij,llm+1)=0.
-          wq(ij,1)=0.
+          wq(ij,llm+1,iq)=0.
+          wq(ij,1,iq)=0.
        ENDDO
 c$OMP END MASTER
 c$OMP BARRIER
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+          DO ij=ijb,ije
+           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+           !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
+           w(ij,l,iq2)=wq(ij,l,iq)
+          enddo   
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+c$OMP BARRIER
+
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi  
+
+! CRisi: On rajoute ici une barrière car on veut être sur que tous les
+! wq soient synchronisés
+
+c$OMP BARRIER
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          DO ij=ijb,ije
-            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+            newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)
+     &         +wq(ij,l+1,iq)-wq(ij,l,iq))
      &         /newmasse
-            masse(ij,l)=newmasse
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
+            masse(ij,l,iq)=newmasse
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      
+! retablir les fils en rapport de melange par rapport a l'air:
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
 
       RETURN
Index: LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_loc.F	(revision 2298)
@@ -27,5 +27,7 @@
       USE Write_Field_loc
       USE VAMPIR
-      USE infotrac, ONLY : nqtot
+      ! CRisi: on rajoute variables utiles d'infotrac  
+      USE infotrac, ONLY : nqtot,nqperes,nqdesc,nqfils,iqfils, 
+     &    ok_iso_verif
       USE vlspltgen_mod
       IMPLICIT NONE
@@ -64,5 +66,5 @@
       REAL ptarg,pdelarg,foeew,zdelta
       REAL tempe(ijb_u:ije_u)
-      INTEGER ijb,ije,iq
+      INTEGER ijb,ije,iq,iq2,ifils
       LOGICAL, SAVE :: firstcall=.TRUE.
 !$OMP THREADPRIVATE(firstcall)
@@ -150,17 +152,21 @@
       ije=ij_end
 
+      DO iq=1,nqtot
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
       DO l=1,llm
          DO ij=ijb,ije
-            mw(ij,l)=w(ij,l) * zzw
+            mw(ij,l,iq)=w(ij,l) * zzw
          ENDDO
       ENDDO
 c$OMP END DO NOWAIT
-
+      ENDDO
+
+      DO iq=1,nqtot  
 c$OMP MASTER
       DO ij=ijb,ije
-         mw(ij,llm+1)=0.
+         mw(ij,llm+1,iq)=0.
       ENDDO
 c$OMP END MASTER
+      ENDDO
 
 c      CALL SCOPY(ijp1llm,q,1,zq,1)
@@ -170,5 +176,5 @@
        ije=ij_end
 
-      DO iq=1,nqtot
+      DO iq=1,nqtot       
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
         DO l=1,llm
@@ -179,5 +185,5 @@
       ENDDO
 
-#ifdef DEBUG_IO    
+#ifdef DEBUG_IO     
        CALL WriteField_u('mu',mu)
        CALL WriteField_v('mv',mv)
@@ -186,11 +192,169 @@
 #endif
 
+      ! verif temporaire
+      ijb=ij_begin
+      ije=ij_end  
+      if (ok_iso_verif) then
+        call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
+      endif !if (ok_iso_verif) then   
+
 c$OMP BARRIER           
-      DO iq=1,nqtot
-
+!      DO iq=1,nqtot
+      DO iq=1,nqperes ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
+       !write(*,*) 'vlspltgen 192: iq,iadv=',iq,iadv(iq)
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq)) 
+#endif
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALO        
+! CRisi: on ajoute les nombres de fils et tableaux des fils
+! On suppose qu'on ne peut advecter les fils que par le schéma 10.  
+	  call vlx_loc(zq,pente_max,zm,mu,
+     &	             ij_begin,ij_begin+2*iip1-1,iq)
+          call vlx_loc(zq,pente_max,zm,mu,
+     &               ij_end-2*iip1+1,ij_end,iq)
+#else
+	  call vlx_loc(zq,pente_max,zm,mu,
+     &	             ij_begin,ij_end,iq)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+! CRisi
+          do ifils=1,nqdesc(iq)
+            iq2=iqfils(ifils,iq)
+            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+          enddo
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER
+	else if (iadv(iq)==14) then
+
+#ifdef _ADV_HALO           
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                   qsat,ij_end-2*iip1+1,ij_end,iq)
+#else
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                   qsat,ij_begin,ij_end,iq)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+          do ifils=1,nqdesc(iq)
+            iq2=iqfils(ifils,iq)
+            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+          enddo
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo !DO iq=1,nqperes
+      
+      
+c$OMP BARRIER      
+c$OMP MASTER      
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest1)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER       
+c$OMP BARRIER
+
+      ! verif temporaire
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1  
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end  
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
+      endif !if (ok_iso_verif) then
+
+      do iq=1,nqperes
+        !write(*,*) 'vlspltgen 279: iq=',iq
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALLO
+          call vlx_loc(zq,pente_max,zm,mu,
+     &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif        
+	else if (iadv(iq)==14) then
+#ifdef _ADV_HALLO
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif    
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest1)
+!      call WaitSendRequest(MyRequest1)
+c$OMP BARRIER
+       call WaitRequest(MyRequest1)
+
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
+      endif !if (ok_iso_verif) then        
+      if (ok_iso_verif) then
+           ijb=ij_begin-2*iip1
+           ije=ij_end+2*iip1
+           if (pole_nord) ijb=ij_begin
+           if (pole_sud)  ije=ij_end
+           call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
+      endif !if (ok_iso_verif) then  
+
+      do iq=1,nqperes
+       !write(*,*) 'vlspltgen 321: iq=',iq
 #ifdef DEBUG_IO    
        CALL WriteField_u('zq',zq(:,:,iq))
        CALL WriteField_u('zm',zm(:,:,iq))
 #endif
+
         if(iadv(iq) == 0) then
 	
@@ -198,47 +362,12 @@
 	
 	else if (iadv(iq)==10) then
-
-#ifdef _ADV_HALO        
-	  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &	             ij_begin,ij_begin+2*iip1-1)
-          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &               ij_end-2*iip1+1,ij_end)
-#else
-	  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &	             ij_begin,ij_end)
-#endif
-
-c$OMP MASTER
-          call VTb(VTHallo)
-c$OMP END MASTER
-          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
-          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
-
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER
+        
+          call vly_loc(zq,pente_max,zm,mv,iq)
+  
 	else if (iadv(iq)==14) then
-
-#ifdef _ADV_HALO           
-          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                   qsat,ij_begin,ij_begin+2*iip1-1)
-          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                   qsat,ij_end-2*iip1+1,ij_end)
-#else
-
-          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                   qsat,ij_begin,ij_end)
-#endif
-
-c$OMP MASTER
-          call VTb(VTHallo)
-c$OMP END MASTER
-
-          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
-          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
-
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER 
+      
+          call vlyqs_loc(zq,pente_max,zm,mv,
+     &                   qsat,iq)
+ 
         else
 	
@@ -246,78 +375,92 @@
       
         endif
-      
-      enddo
-      
-      
-c$OMP BARRIER      
-c$OMP MASTER      
-      call VTb(VTHallo)
-c$OMP END MASTER
-
-      call SendRequest(MyRequest1)
-
-c$OMP MASTER
-      call VTe(VTHallo)
-c$OMP END MASTER       
-c$OMP BARRIER
-      do iq=1,nqtot
-
-        if(iadv(iq) == 0) then
-	
-	  cycle 
-	
-	else if (iadv(iq)==10) then
-
-#ifdef _ADV_HALLO
-          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                 ij_begin+2*iip1,ij_end-2*iip1)
-#endif        
-	else if (iadv(iq)==14) then
-#ifdef _ADV_HALLO
-          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1)
-#endif    
-        else
-	
-	  stop 'vlspltgen_p : schema non parallelise'
-      
-        endif
-      
-      enddo
-c$OMP BARRIER      
-c$OMP MASTER
-      call VTb(VTHallo)
-c$OMP END MASTER
-
-!      call WaitRecvRequest(MyRequest1)
-!      call WaitSendRequest(MyRequest1)
-c$OMP BARRIER
-       call WaitRequest(MyRequest1)
-
-
-c$OMP MASTER
-      call VTe(VTHallo)
-c$OMP END MASTER
-c$OMP BARRIER
-
-
-      do iq=1,nqtot
+       
+       enddo
+
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
+      endif !if (ok_iso_verif) then
+
+      do iq=1,nqperes
+      !write(*,*) 'vlspltgen 349: iq=',iq
 #ifdef DEBUG_IO    
        CALL WriteField_u('zq',zq(:,:,iq))
        CALL WriteField_u('zm',zm(:,:,iq))
 #endif
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+
+c$OMP BARRIER        
+#ifdef _ADV_HALLO
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin,ij_begin+2*iip1-1,iq)
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_end-2*iip1+1,ij_end,iq)
+#else
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin,ij_end,iq)
+#endif
+c$OMP BARRIER
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
+          ! CRisi
+          do ifils=1,nqdesc(iq)
+            iq2=iqfils(ifils,iq)
+            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
+            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
+          enddo      
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER	
+c$OMP BARRIER
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+
+c$OMP MASTER        
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER	
+
+
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
+      endif !if (ok_iso_verif) then 
+
+c$OMP BARRIER
+      do iq=1,nqperes
+      !write(*,*) 'vlspltgen 409: iq=',iq
+
         if(iadv(iq) == 0) then
-	
+	  
 	  cycle 
 	
-	else if (iadv(iq)==10) then
-        
-          call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
-  
-	else if (iadv(iq)==14) then
-      
-          call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
-     &                   qsat)
- 
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+c$OMP BARRIER        
+
+#ifdef _ADV_HALLO
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+
+c$OMP BARRIER        
         else
 	
@@ -325,162 +468,102 @@
       
         endif
-       
-       enddo
-
-
-      do iq=1,nqtot
+      
+      enddo
+      !write(*,*) 'vlspltgen_loc 476'
+
+c$OMP BARRIER
+      !write(*,*) 'vlspltgen_loc 477'
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest2)
+!      call WaitSendRequest(MyRequest2)
+c$OMP BARRIER
+       CALL WaitRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+      !write(*,*) 'vlspltgen_loc 494'
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
+      endif !if (ok_iso_verif) then
+
+      do iq=1,nqperes
+      !write(*,*) 'vlspltgen 449: iq=',iq
 #ifdef DEBUG_IO    
        CALL WriteField_u('zq',zq(:,:,iq))
        CALL WriteField_u('zm',zm(:,:,iq))
 #endif
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_loc(zq,pente_max,zm,mv,iq)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_loc(zq,pente_max,zm,mv,
+     &                   qsat,iq)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo !do iq=1,nqperes
+
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
+      endif !if (ok_iso_verif) then
+
+      do iq=1,nqperes
+      !write(*,*) 'vlspltgen 477: iq=',iq
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
         if(iadv(iq) == 0) then 
 	  
 	  cycle 
 	
-	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
-
-c$OMP BARRIER        
-#ifdef _ADV_HALLO
-          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
-     &               ij_begin,ij_begin+2*iip1-1)
-          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
-     &               ij_end-2*iip1+1,ij_end)
-#else
-          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
-     &               ij_begin,ij_end)
-#endif
-c$OMP BARRIER
-
-c$OMP MASTER
-          call VTb(VTHallo)
-c$OMP END MASTER
-
-          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
-          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
-
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER	
-c$OMP BARRIER
-        else
-	
-	  stop 'vlspltgen_p : schema non parallelise'
-      
-        endif
-      
-      enddo
-c$OMP BARRIER      
-
-c$OMP MASTER        
-      call VTb(VTHallo)
-c$OMP END MASTER
-
-      call SendRequest(MyRequest2)
-
-c$OMP MASTER
-      call VTe(VTHallo)
-c$OMP END MASTER	
-
-c$OMP BARRIER
-      do iq=1,nqtot
-
-        if(iadv(iq) == 0) then
-	  
-	  cycle 
-	
-	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
-c$OMP BARRIER        
-
-#ifdef _ADV_HALLO
-          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
-     &               ij_begin+2*iip1,ij_end-2*iip1)
-#endif
-
-c$OMP BARRIER        
-        else
-	
-	  stop 'vlspltgen_p : schema non parallelise'
-      
-        endif
-      
-      enddo
-
-c$OMP BARRIER
-c$OMP MASTER
-      call VTb(VTHallo)
-c$OMP END MASTER
-
-!      call WaitRecvRequest(MyRequest2)
-!      call WaitSendRequest(MyRequest2)
-c$OMP BARRIER
-       CALL WaitRequest(MyRequest2)
-
-c$OMP MASTER
-      call VTe(VTHallo)
-c$OMP END MASTER
-c$OMP BARRIER
-
-
-      do iq=1,nqtot
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-        if(iadv(iq) == 0) then
-	
-	  cycle 
-	
 	else if (iadv(iq)==10) then
         
-          call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
+          call vlx_loc(zq,pente_max,zm,mu,
+     &               ij_begin,ij_end,iq)
   
 	else if (iadv(iq)==14) then
       
-          call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
-     &                   qsat)
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                 qsat, ij_begin,ij_end,iq)
  
         else
 	
-	  stop 'vlspltgen_p : schema non parallelise'
+          stop 'vlspltgen_p : schema non parallelise'
       
         endif
        
-       enddo
-
-
-      do iq=1,nqtot
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-        if(iadv(iq) == 0) then 
-	  
-	  cycle 
-	
-	else if (iadv(iq)==10) then
-        
-          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &               ij_begin,ij_end)
-  
-	else if (iadv(iq)==14) then
-      
-          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
-     &                 qsat, ij_begin,ij_end)
- 
-        else
-	
-          stop 'vlspltgen_p : schema non parallelise'
-      
-        endif
-       
-       enddo
-
+       enddo !do iq=1,nqperes
+
+      !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
+      if (ok_iso_verif) then
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
+      endif !if (ok_iso_verif) then
      
       ijb=ij_begin
       ije=ij_end
+      !write(*,*) 'vlspltgen_loc 557'
 c$OMP BARRIER      
 
-
+      !write(*,*) 'vlspltgen_loc 559'  
       DO iq=1,nqtot
+       !write(*,*) 'vlspltgen_loc 561, iq=',iq  
 #ifdef DEBUG_IO    
        CALL WriteField_u('zq',zq(:,:,iq))
@@ -495,5 +578,6 @@
            ENDDO
         ENDDO
-c$OMP END DO NOWAIT          
+c$OMP END DO NOWAIT    
+      !write(*,*) 'vlspltgen_loc 575'      
 
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
@@ -504,8 +588,11 @@
         ENDDO
 c$OMP END DO NOWAIT  
-
-      ENDDO
+      !write(*,*) 'vlspltgen_loc 583'  
+      ENDDO !DO iq=1,nqtot
         
-      
+      if (ok_iso_verif) then
+           call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
+      endif !if (ok_iso_verif) then
+
 c$OMP BARRIER
 
@@ -516,4 +603,5 @@
 cc$OMP BARRIER
 
+      !write(*,*) 'vlspltgen 597: sortie'  
       RETURN
       END
Index: LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_mod.F90	(revision 2298)
@@ -2,7 +2,7 @@
 
   REAL,POINTER,SAVE :: qsat(:,:)
-  REAL,POINTER,SAVE :: mu(:,:)
+  REAL,POINTER,SAVE :: mu(:,:) ! CRisi: on ajoute une dimension
   REAL,POINTER,SAVE :: mv(:,:)
-  REAL,POINTER,SAVE :: mw(:,:)
+  REAL,POINTER,SAVE :: mw(:,:,:)
   REAL,POINTER,SAVE :: zm(:,:,:)
   REAL,POINTER,SAVE :: zq(:,:,:)
@@ -25,5 +25,5 @@
     CALL allocate_u(mu,llm,d)
     CALL allocate_v(mv,llm,d)
-    CALL allocate_u(mw,llm+1,d)
+    CALL allocate_u(mw,llm+1,nqtot,d)
     CALL allocate_u(zm,llm,nqtot,d)
     CALL allocate_u(zq,llm,nqtot,d)
Index: LMDZ5/branches/testing/libf/dyn3dmem/vlspltqs_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/vlspltqs_loc.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/vlspltqs_loc.F	(revision 2298)
@@ -1,12 +1,13 @@
-      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x)
+      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
 c
 c    ********************************************************************
-c     Shema  d'advection " pseudo amont " .
+c     Shema  d''advection " pseudo amont " .
 c    ********************************************************************
 c
 c   --------------------------------------------------------------------
       USE parallel_lmdz
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi  
       IMPLICIT NONE
 c
@@ -20,8 +21,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
       REAL u_m( ijb_u:ije_u,llm )
-      REAL q(ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot)
       REAL qsat(ijb_u:ije_u,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -36,4 +38,7 @@
       REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
       REAL u_mq(ijb_u:ije_u,llm)
+      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
+
 
       REAL      SSUM
@@ -42,4 +47,6 @@
       INTEGER ijb,ije,ijb_x,ije_x
       
+      !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
+!     &   iq,ijb_x
 
 c   calcul de la pente a droite et a gauche de la maille
@@ -65,7 +72,7 @@
          DO l = 1, llm
             DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
 c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
-c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
@@ -120,5 +127,5 @@
          DO l = 1, llm
             DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l)-q(ij,l)
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
@@ -179,11 +186,11 @@
       DO l=1,llm
        DO ij=ijb,ije-1
-          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
-     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
      ,                     u_m(ij,l))
           zdum(ij,l)=0.5*zdum(ij,l)
           u_mq(ij,l)=cvmgp(
-     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
-     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
      ,                u_m(ij,l))
           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
@@ -195,16 +202,16 @@
 c   on cumule le flux correspondant a toutes les mailles dont la masse
 c   au travers de la paroi pENDant le pas de temps.
-c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
+c   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
        DO ij=ijb,ije-1
           IF (u_m(ij,l).gt.0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
              u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
           ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
              u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
           ENDIF
        ENDDO
@@ -273,5 +280,5 @@
                ENDDO
                niju=iju
-c              PRINT*,'niju,nl',niju,nl(l)
+               !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
 
 c  traitement des mailles
@@ -285,26 +292,28 @@
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m-masse(ijq,l)
+                     do while(zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
+     &                     *masse(ijq,l,iq) 
+                        zu_m=zu_m-masse(ijq,l,iq)
                         i=mod(i-2+iim,iim)+1
                         ijq=(j-1)*iip1+i
                      ENDDO
 c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
-     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)
+     &                 +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ELSE
                      ijq=ij+1
                      i=ijq-(j-1)*iip1
 c   accumulation pour les mailles completements advectees
-                     do while(-zu_m.gt.masse(ijq,l))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
-                        zu_m=zu_m+masse(ijq,l)
+                     do while(-zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
+     &                   *masse(ijq,l,iq)
+                        zu_m=zu_m+masse(ijq,l,iq)
                         i=mod(i,iim)+1
                         ijq=(j-1)*iip1+i
                      ENDDO
 c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
-     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
+     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
                   ENDIF
                ENDDO
@@ -325,28 +334,77 @@
 c$OMP END DO NOWAIT
 
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlspltqs 336: iq,ijb_x,nqfils(iq)=',
+!     &     iq,ijb_x,nqfils(iq)  
+
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb,ije
+           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)      
+          enddo   
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqfils(iq)
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
+         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+! end CRisi
+
+      !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x   
+
 c   calcul des tendances
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          DO ij=ijb+1,ije
-            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+
+            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
      &      u_mq(ij-1,l)-u_mq(ij,l))
      &      /new_m
-            masse(ij,l)=new_m
-         ENDDO
-c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+            masse(ij,l,iq)=new_m
+         ENDDO
+c   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
          DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l)=q(ij,l)
-            masse(ij-iim,l)=masse(ij,l)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
+            q(ij-iim,l,iq)=q(ij,l,iq)
+            masse(ij-iim,l,iq)=masse(ij,l,iq)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
+
+! retablir les fils en rapport de melange par rapport a l'air:
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb+1,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+          DO ij=ijb+iip1-1,ije,iip1
+             q(ij-iim,l,iq2)=q(ij,l,iq2)
+          enddo ! DO ij=ijb+iip1-1,ije,iip1
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
+
 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
-c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
 
 
       RETURN
       END
-      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat)
+      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
 c
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
@@ -361,4 +419,5 @@
 c   --------------------------------------------------------------------
       USE parallel_lmdz
+      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi  
       IMPLICIT NONE
 c
@@ -373,8 +432,9 @@
 c   Arguments:
 c   ----------
-      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
       REAL masse_adv_v( ijb_v:ije_v,llm)
-      REAL q(ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot)
       REAL qsat(ijb_u:ije_u,llm)
+      INTEGER iq ! CRisi
 c
 c      Local 
@@ -386,5 +446,5 @@
       REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
       REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
-      REAL qbyv(ijb_v:ije_v,llm)
+      REAL qbyv(ijb_v:ije_v,llm,nqtot)
 
       REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
@@ -402,4 +462,7 @@
 c
 c
+      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
+
       REAL      SSUM
 
@@ -407,6 +470,18 @@
       INTEGER ijb,ije
 
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1  
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+      ij=3525
+      l=3
+      if ((ij.ge.ijb).and.(ij.le.ije)) then
+        !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
+!     &             ij,l,iq,ijb,q(ij,l,:)
+      endif  
+
       IF(first) THEN
          PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         PRINT*,'vlyqs_loc, iq=',iq
          first=.false.
          do i=2,iip1
@@ -439,5 +514,5 @@
       if (pole_nord) then
         DO i = 1, iim
-          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
         ENDDO
         qpns   = SSUM( iim,  airescb ,1 ) / airej2
@@ -446,5 +521,5 @@
       if (pole_sud) then
         DO i = 1, iim
-          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
         ENDDO
         qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
@@ -460,5 +535,5 @@
       
       DO ij=ijb,ije
-         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
          adyqv(ij)=abs(dyqv(ij))
       ENDDO
@@ -482,5 +557,5 @@
 c   calcul des pentes aux poles
         DO ij=1,iip1
-           dyq(ij,l)=qpns-q(ij+iip1,l)
+           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
         ENDDO
 
@@ -513,5 +588,5 @@
 
         DO ij=1,iip1
-           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
         ENDDO
 
@@ -636,14 +711,45 @@
        DO ij=ijb,ije
          IF( masse_adv_v(ij,l).GT.0. ) THEN
-           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
-     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+           qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
+     ,      /masse(ij+iip1,l,iq)))
          ELSE
-              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+              qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
          ENDIF
-          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+          qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
        ENDDO
       ENDDO
 c$OMP END DO NOWAIT
+
+! CRisi: appel récursif de l'advection sur les fils.
+! Il faut faire ça avant d'avoir mis à jour q et masse
+      !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
+      
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end  
+
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb,ije
+           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
+           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)   
+          enddo   
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+        do ifils=1,nqfils(iq)
+         iq2=iqfils(ifils,iq)
+         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+        enddo !do ifils=1,nqfils(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+        
+! end CRisi
 
       ijb=ij_begin
@@ -655,9 +761,9 @@
       DO l=1,llm
          DO ij=ijb,ije
-            newmasse=masse(ij,l)
+            newmasse=masse(ij,l,iq)
      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
-     &         /newmasse
-            masse(ij,l)=newmasse
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq)
+     &         -qbyv(ij-iip1,l,iq))/newmasse
+            masse(ij,l,iq)=newmasse
          ENDDO
 c.-. ancienne version
@@ -665,11 +771,11 @@
          IF (pole_nord) THEN
 
-           convpn=SSUM(iim,qbyv(1,l),1)/apoln
+           convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
            convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
            DO ij = 1,iip1
-              newmasse=masse(ij,l)+convmpn*aire(ij)
-              q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+              newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
      &                 newmasse
-              masse(ij,l)=newmasse
+              masse(ij,l,iq)=newmasse
            ENDDO
 	 
@@ -678,11 +784,11 @@
 	 IF (pole_sud) THEN
 	 
-	   convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+	   convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),iq,1)/apols
            convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
            DO ij = ip1jm+1,ip1jmp1
-              newmasse=masse(ij,l)+convmps*aire(ij)
-              q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+              newmasse=masse(ij,l,iq)+convmps*aire(ij)
+              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
      &                 newmasse
-              masse(ij,l)=newmasse
+              masse(ij,l,iq)=newmasse
            ENDDO
 	 
@@ -691,27 +797,48 @@
 
 c._. nouvelle version
-c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convpn=SSUM(iim,qbyv(1,l,iq),1)
 c        convmpn=ssum(iim,masse_adv_v(1,l),1)
-c        oldmasse=ssum(iim,masse(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l,iq),1)
 c        newmasse=oldmasse+convmpn
-c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
 c        newmasse=newmasse/apoln
 c        DO ij = 1,iip1
-c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           q(ij,l,iq)=newq
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
-c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
 c        newmasse=oldmasse+convmps
-c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
 c        newmasse=newmasse/apols
 c        DO ij = ip1jm+1,ip1jmp1
-c           q(ij,l)=newq
-c           masse(ij,l)=newmasse*aire(ij)
+c           q(ij,l,iq)=newq
+c           masse(ij,l,iq)=newmasse*aire(ij)
 c        ENDDO
 c._. fin nouvelle version
       ENDDO
 c$OMP END DO NOWAIT
+
+! retablir les fils en rapport de melange par rapport a l'air:
+      ijb=ij_begin
+      ije=ij_end
+!      if (pole_nord) ijb=ij_begin+iip1
+!      if (pole_sud)  ije=ij_end-iip1
+  
+      if (nqfils(iq).gt.0) then  
+       do ifils=1,nqdesc(iq)
+         iq2=iqfils(ifils,iq)  
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+         DO l=1,llm
+          DO ij=ijb,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
+          enddo
+         enddo
+c$OMP END DO NOWAIT
+        enddo !do ifils=1,nqdesc(iq)
+      endif !if (nqfils(iq).gt.0) then
+
+
       RETURN
       END
Index: LMDZ5/branches/testing/libf/dyn3dmem/vlz_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dmem/vlz_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dmem/vlz_mod.F90	(revision 2298)
@@ -1,8 +1,11 @@
 MODULE vlz_mod
 
-  REAL,POINTER,SAVE :: wq(:,:)
+  REAL,POINTER,SAVE :: wq(:,:,:)
   REAL,POINTER,SAVE :: dzq(:,:)
   REAL,POINTER,SAVE :: dzqw(:,:)
   REAL,POINTER,SAVE :: adzqw(:,:)
+  ! CRisi: pour les traceurs:  
+  !REAL,POINTER,SAVE :: masseq(:,:,:)
+  REAL,POINTER,SAVE :: Ratio(:,:,:)
   
 CONTAINS
@@ -18,8 +21,12 @@
     
     d=>distrib_vanleer
-    CALL allocate_u(wq,llm+1,d)
+    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 (nqdesc_tot.gt.0) then
+    !CALL allocate_u(masseq,llm,nqtot,d)
+    CALL allocate_u(Ratio,llm,nqtot,d)
+    endif !if (nqdesc_tot.gt.0) then
 
   END SUBROUTINE vlz_allocate
@@ -29,4 +36,5 @@
   USE bands
   USE parallel_lmdz
+  USE infotrac
   IMPLICIT NONE
     TYPE(distrib),INTENT(IN) :: dist
@@ -36,4 +44,9 @@
     CALL switch_u(dzqw,distrib_vanleer,dist)
     CALL switch_u(adzqw,distrib_vanleer,dist)
+    ! CRisi:
+    if (nqdesc_tot.gt.0) then    
+    !CALL switch_u(masseq,distrib_vanleer,dist)
+    CALL switch_u(Ratio,distrib_vanleer,dist)
+    endif !if (nqdesc_tot.gt.0) then     
 
   END SUBROUTINE vlz_switch_vanleer  
Index: LMDZ5/branches/testing/libf/dyn3dpar/advtrac_p.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/advtrac_p.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/advtrac_p.F90	(revision 2298)
@@ -10,7 +10,8 @@
   !            M.A Filiberti (04/2002)
   !
-  USE parallel_lmdz
-  USE Write_Field_p
-  USE Bands
+  USE parallel_lmdz, ONLY: ij_begin,ij_end,OMP_CHUNK,pole_nord,pole_sud,&
+                           setdistrib
+  USE Write_Field_p, ONLY: WriteField_p
+  USE Bands, ONLY: jj_Nb_Caldyn,jj_Nb_vanleer
   USE mod_hallo
   USE Vampir
Index: LMDZ5/branches/testing/libf/dyn3dpar/calfis_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/calfis_p.F	(revision 2274)
+++ 	(revision )
@@ -1,1117 +1,0 @@
-!
-! $Id$
-!
-C
-C
-      SUBROUTINE calfis_p(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)
-#ifdef CPP_PHYS
-! If using physics
-      USE dimphy
-      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
-      USE mod_interface_dyn_phys
-      USE IOPHY
-#endif
-      USE parallel_lmdz, ONLY : omp_chunk, using_mpi
-      USE Write_Field
-      Use Write_field_p
-      USE Times
-      USE infotrac, ONLY: nqtot, niadv, tname
-      USE control_mod, ONLY: planet_type, nsplit_phys
-
-      IMPLICIT NONE
-c=======================================================================
-c
-c   1. rearrangement des tableaux et transformation
-c      variables dynamiques  >  variables physiques
-c   2. calcul des termes physiques
-c   3. retransformation des tendances physiques en tendances dynamiques
-c
-c   remarques:
-c   ----------
-c
-c    - les vents sont donnes dans la physique par leurs composantes 
-c      naturelles.
-c    - la variable thermodynamique de la physique est une variable
-c      intensive :   T 
-c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
-c    - les deux seules variables dependant de la geometrie necessaires
-c      pour la physique sont la latitude pour le rayonnement et 
-c      l'aire de la maille quand on veut integrer une grandeur 
-c      horizontalement.
-c    - les points de la physique sont les points scalaires de la 
-c      la dynamique; numerotation:
-c          1 pour le pole nord
-c          (jjm-1)*iim pour l'interieur du domaine
-c          ngridmx pour le pole sud
-c      ---> ngridmx=2+(jjm-1)*iim
-c
-c     Input :
-c     -------
-c       ecritphy        frequence d'ecriture (en jours)de histphy
-c       pucov           covariant zonal velocity
-c       pvcov           covariant meridional velocity 
-c       pteta           potential temperature
-c       pps             surface pressure
-c       pmasse          masse d'air dans chaque maille
-c       pts             surface temperature  (K)
-c       callrad         clef d'appel au rayonnement
-c
-c    Output :
-c    --------
-c        pdufi          tendency for the natural zonal velocity (ms-1)
-c        pdvfi          tendency for the natural meridional velocity 
-c        pdhfi          tendency for the potential temperature
-c        pdtsfi         tendency for the surface temperature
-c
-c        pdtrad         radiative tendencies  \  both input
-c        pfluxrad       radiative fluxes      /  and output
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "temps.h"
-
-      INTEGER ngridmx
-      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
-
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "iniprint.h"
-#ifdef CPP_MPI
-      include 'mpif.h'
-#endif
-c    Arguments :
-c    -----------
-      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 ! not used
-      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 dynamics grid
-
-      ! 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)
-
-#ifdef CPP_PHYS
-! Ehouarn: for now calfis_p needs some informations from physics to compile
-c    Local variables :
-c    -----------------
-
-      INTEGER i,j,l,ig0,ig,iq,iiq
-      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
-      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
-c
-      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
-      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
-c
-      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
-      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
-c
-      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
-      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
-
-c
-      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
-      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
-      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
-      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
-      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
-      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Introduction du splitting (FH)
-! Question pour Yann :
-! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
-! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
-! soit allocatable (plutot par exemple que de passer une dimension
-! dépendant du process en argument des routines) et que, du coup,
-! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
-! Tu confirmes ?
-! J'ai suivi le même principe pour les zdufic_omp
-! Mais c'est surement bien que tu controles.
-! 
-
-      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
-      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
-      REAL jH_cur_split,zdt_split
-      LOGICAL debut_split,lafin_split
-      INTEGER isplit
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
-c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
-c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
-c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
-c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
-
-      LOGICAL,SAVE :: first_omp=.true.
-c$OMP THREADPRIVATE(first_omp)
-      
-      REAL zsin(iim),zcos(iim),z1(iim)
-      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
-      REAL unskap, pksurcp
-c
-      REAL SSUM
-
-      LOGICAL,SAVE :: firstcal=.true., debut=.true.
-c$OMP THREADPRIVATE(firstcal,debut)
-      
-      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
-      INTEGER :: ierr
-#ifdef CPP_MPI
-      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
-#else
-      INTEGER,dimension(1,4) :: Status
-#endif
-      INTEGER, dimension(4) :: Req
-      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
-      integer :: k,kstart,kend
-      INTEGER :: offset  
-
-      LOGICAL tracerdyn
-c
-c-----------------------------------------------------------------------
-c
-c    1. Initialisations :
-c    --------------------
-c
-
-      klon=klon_mpi
-      
-c
-      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
-         STOP
-        ENDIF
-c$OMP MASTER
-      ALLOCATE(zpsrf(klon))
-      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
-      ALLOCATE(zphi(klon,llm),zphis(klon))
-      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
-      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
-      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
-      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
-      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
-      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
-      ALLOCATE(zdpsrf(klon))
-      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
-      ALLOCATE(flxwfi(klon,llm))
-c$OMP END MASTER
-c$OMP BARRIER	  
-      ELSE
-          debut = .FALSE.
-      ENDIF
-
-c
-c
-c-----------------------------------------------------------------------
-c   40. transformation des variables dynamiques en variables physiques:
-c   ---------------------------------------------------------------
-
-c   41. pressions au sol (en Pascals)
-c   ----------------------------------
-
-c$OMP MASTER
-      call start_timer(timer_physic)
-c$OMP END MASTER
-
-c$OMP MASTER             
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-      do ig0=1,klon
-        i=index_i(ig0)
-        j=index_j(ig0)
-        zpsrf(ig0)=pps(i,j)
-      enddo
-c$OMP END MASTER
-
-
-c   42. pression intercouches :
-c
-c   -----------------------------------------------------------------
-c     .... zplev  definis aux (llm +1) interfaces des couches  ....
-c     .... zplay  definis aux (  llm )    milieux des couches  .... 
-c   -----------------------------------------------------------------
-
-c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
-c
-       unskap   = 1./ kappa
-c
-c      print *,omp_rank,'klon--->',klon
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1, llmp1
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        do ig0=1,klon
-          i=index_i(ig0)
-          j=index_j(ig0)
-          zplev( ig0,l ) = pp(i,j,l)
-        enddo
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c
-
-c   43. temperature naturelle (en K) et pressions milieux couches .
-c   ---------------------------------------------------------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        do ig0=1,klon
-          i=index_i(ig0)
-          j=index_j(ig0)
-          pksurcp        = ppk(i,j,l) / cpp
-          zplay(ig0,l)   = preff * pksurcp ** unskap
-          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
-        enddo
-
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   43.bis traceurs
-c   ---------------
-c
-
-      DO iq=1,nqtot
-         iiq=niadv(iq)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-           do ig0=1,klon
-             i=index_i(ig0)
-             j=index_j(ig0)
-             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
-           enddo
-         ENDDO
-c$OMP END DO NOWAIT	 
-      ENDDO
-
-
-c   Geopotentiel calcule par rapport a la surface locale:
-c   -----------------------------------------------------
-
-      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
-
-      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
-
-c$OMP BARRIER
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-	 DO ig=1,klon
-	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
-	 ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-      
-
-c
-c   45. champ u:
-c   ------------
-
-      kstart=1
-      kend=klon
-      
-      if (is_north_pole) kstart=2
-      if (is_south_pole) kend=klon-1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!CDIR SPARSE
-        do ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          if (i==1) then
-            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
-     $                         + pucov(1,j,l)/cu(1,j) )
-          else
-            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
-     $                       + pucov(i,j,l)/cu(i,j) )
-          endif
-        enddo
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   46.champ v:
-c   -----------
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-        DO ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
-     $                       + pvcov(i,j,l)/cv(i,j) )
-    
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   47. champs de vents aux pole nord   
-c   ------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      if (is_north_pole) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO l=1,llm
-
-           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
-           DO i=2,iim
-              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
-           ENDDO
-  
-           DO i=1,iim
-              zcos(i)   = COS(rlonv(i))*z1(i)
-              zsin(i)   = SIN(rlonv(i))*z1(i)
-           ENDDO
-  
-           zufi(1,l)  = SSUM(iim,zcos,1)/pi
-           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
-  
-        ENDDO
-c$OMP END DO NOWAIT      
-      endif
-
-
-c   48. champs de vents aux pole sud:
-c   ---------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      if (is_south_pole) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO l=1,llm
-  
-         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
-           DO i=2,iim
-             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
-	   ENDDO
-  
-           DO i=1,iim
-              zcos(i)    = COS(rlonv(i))*z1(i)
-              zsin(i)    = SIN(rlonv(i))*z1(i)
-	   ENDDO
-  
-           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
-           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
-        ENDDO
-c$OMP END DO NOWAIT       
-      endif
-
-c On change de grille, dynamique vers physiq, pour le flux de masse verticale
-      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
-
-c-----------------------------------------------------------------------
-c   Appel de la physique:
-c   ---------------------
-
-
-c$OMP BARRIER
-      if (first_omp) then
-        klon=klon_omp
-
-        allocate(zplev_omp(klon,llm+1))
-        allocate(zplay_omp(klon,llm))
-        allocate(zphi_omp(klon,llm))
-        allocate(zphis_omp(klon))
-        allocate(presnivs_omp(llm))
-        allocate(zufi_omp(klon,llm))
-        allocate(zvfi_omp(klon,llm))
-        allocate(ztfi_omp(klon,llm))
-        allocate(zqfi_omp(klon,llm,nqtot))
-        allocate(zdufi_omp(klon,llm))
-        allocate(zdvfi_omp(klon,llm))
-        allocate(zdtfi_omp(klon,llm))
-        allocate(zdqfi_omp(klon,llm,nqtot))
-        allocate(zdufic_omp(klon,llm))
-        allocate(zdvfic_omp(klon,llm))
-        allocate(zdtfic_omp(klon,llm))
-        allocate(zdqfic_omp(klon,llm,nqtot))
-        allocate(zdpsrf_omp(klon))
-        allocate(flxwfi_omp(klon,llm))
-	first_omp=.false.
-      endif
-       
-	   
-      klon=klon_omp
-      offset=klon_omp_begin-1
-      
-      do l=1,llm+1
-        do i=1,klon
-          zplev_omp(i,l)=zplev(offset+i,l)
-	enddo 
-      enddo
-	  
-       do l=1,llm
-        do i=1,klon  
-	  zplay_omp(i,l)=zplay(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zphi_omp(i,l)=zphi(offset+i,l)
-	enddo 
-      enddo
-	
-      do i=1,klon
-	zphis_omp(i)=zphis(offset+i)
-      enddo 
-     
-	
-      do l=1,llm
-        presnivs_omp(l)=presnivs(l)
-      enddo 
-	
-      do l=1,llm
-        do i=1,klon
-	  zufi_omp(i,l)=zufi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zvfi_omp(i,l)=zvfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  ztfi_omp(i,l)=ztfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
-	  enddo
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdufi_omp(i,l)=zdufi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-          zdtfi_omp(i,l)=zdtfi(offset+i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
-	  enddo 
-        enddo
-      enddo
-      	
-      do i=1,klon
-	zdpsrf_omp(i)=zdpsrf(offset+i)
-      enddo 
-
-      do l=1,llm
-        do i=1,klon
-          flxwfi_omp(i,l)=flxwfi(offset+i,l)
-	enddo 
-      enddo
-      
-c$OMP BARRIER
-      
-!$OMP MASTER
-!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
-!$OMP END MASTER
-      zdt_split=dtphys/nsplit_phys
-      zdufic_omp(:,:)=0.
-      zdvfic_omp(:,:)=0.
-      zdtfic_omp(:,:)=0.
-      zdqfic_omp(:,:,:)=0.
-
-#ifdef CPP_PHYS
-      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 physiq (klon,
-     .             llm,
-     .             debut_split,
-     .             lafin_split,
-     .             jD_cur,
-     .             jH_cur_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,
-     .             pducov)
-
-      else if ( planet_type=="generic" ) then
-
-      CALL physiq (klon,     !! ngrid
-     .             llm,            !! nlayer
-     .             nqtot,          !! nq
-     .             tname,          !! tracer names from dynamical core (given in infotrac)
-     .             debut_split,    !! firstcall 
-     .             lafin_split,    !! lastcall
-     .             jD_cur,         !! pday. see leapfrog_p 
-     .             jH_cur_split,   !! ptime "fraction of day"
-     .             zdt_split,      !! ptimestep
-     .             zplev_omp,  !! pplev
-     .             zplay_omp,  !! pplay
-     .             zphi_omp,   !! pphi
-     .             zufi_omp,   !! pu
-     .             zvfi_omp,   !! pv
-     .             ztfi_omp,   !! pt
-     .             zqfi_omp,   !! pq
-     .             flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
-     .             zdufi_omp,  !! pdu
-     .             zdvfi_omp,  !! pdv
-     .             zdtfi_omp,  !! pdt
-     .             zdqfi_omp,  !! pdq
-     .             zdpsrf_omp, !! pdpsrf
-     .             tracerdyn)      !! tracerdyn <-- utilite ???
-
-      endif ! of if (planet_type=="earth")
-
-
-         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
-         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
-         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
-         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
-
-         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
-         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
-         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
-         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
-
-      enddo
-
-#endif
-! of #ifdef CPP_PHYS
-
-      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
-      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
-      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
-      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
-c$OMP BARRIER
-
-      do l=1,llm+1
-        do i=1,klon
-          zplev(offset+i,l)=zplev_omp(i,l)
-	enddo 
-      enddo
-	  
-       do l=1,llm
-        do i=1,klon  
-	  zplay(offset+i,l)=zplay_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zphi(offset+i,l)=zphi_omp(i,l)
-	enddo 
-      enddo
-	
-
-      do i=1,klon
-	zphis(offset+i)=zphis_omp(i)
-      enddo 
-     
-	
-      do l=1,llm
-        presnivs(l)=presnivs_omp(l)
-      enddo 
-	
-      do l=1,llm
-        do i=1,klon
-	  zufi(offset+i,l)=zufi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zvfi(offset+i,l)=zvfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  ztfi(offset+i,l)=ztfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
-	  enddo
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdufi(offset+i,l)=zdufi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do l=1,llm
-        do i=1,klon
-          zdtfi(offset+i,l)=zdtfi_omp(i,l)
-	enddo 
-      enddo
-	
-      do iq=1,nqtot
-        do l=1,llm
-          do i=1,klon
-	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
-	  enddo 
-        enddo
-      enddo
-      	
-      do i=1,klon
-	zdpsrf(offset+i)=zdpsrf_omp(i)
-      enddo 
-      
-
-      klon=klon_mpi
-500   CONTINUE
-c$OMP BARRIER
-
-c$OMP MASTER
-      call stop_timer(timer_physic)
-c$OMP END MASTER
-
-      IF (using_mpi) THEN
-            
-      if (MPI_rank>0) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-       DO l=1,llm      
-        du_send(1:iim,l)=zdufi(1:iim,l)
-        dv_send(1:iim,l)=zdvfi(1:iim,l)
-       ENDDO
-c$OMP END DO NOWAIT       
-
-c$OMP BARRIER
-#ifdef CPP_MPI 
-c$OMP MASTER
-!$OMP CRITICAL (MPI)
-        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
-     &                   COMM_LMDZ,Req(1),ierr)
-        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
-     &                  COMM_LMDZ,Req(2),ierr)
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-c$OMP BARRIER
-     
-      endif
-   
-      if (MPI_rank<MPI_Size-1) then
-c$OMP BARRIER
-#ifdef CPP_MPI 
-c$OMP MASTER      
-!$OMP CRITICAL (MPI)
-        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
-     &                 COMM_LMDZ,Req(3),ierr)
-        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
-     &                 COMM_LMDZ,Req(4),ierr)
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-      endif
-
-c$OMP BARRIER
-
-
-#ifdef CPP_MPI 
-c$OMP MASTER    
-!$OMP CRITICAL (MPI)
-      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
-        call MPI_WAITALL(4,Req(1),Status,ierr)
-      else if (MPI_rank>0) then
-        call MPI_WAITALL(2,Req(1),Status,ierr)
-      else if (MPI_rank <MPI_Size-1) then
-        call MPI_WAITALL(2,Req(3),Status,ierr)
-      endif
-!$OMP END CRITICAL (MPI)
-c$OMP END MASTER
-#endif
-
-c$OMP BARRIER     
-
-      ENDIF ! using_mpi
-      
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-            
-        zdufi2(1:klon,l)=zdufi(1:klon,l)
-        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
-            
-        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
-        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
-  
-         pdhfi(:,jj_begin,l)=0
-         pdqfi(:,jj_begin,l,:)=0
-         pdufi(:,jj_begin,l)=0
-         pdvfi(:,jj_begin,l)=0
-         
-         if (.not. is_south_pole) then
-           pdhfi(:,jj_end,l)=0
-           pdqfi(:,jj_end,l,:)=0
-           pdufi(:,jj_end,l)=0
-           pdvfi(:,jj_end,l)=0
-         endif
-      
-       ENDDO 
-c$OMP END DO NOWAIT
-
-c$OMP MASTER
-       pdpsfi(:,jj_begin)=0    
-       if (.not. is_south_pole) then
-	 pdpsfi(:,jj_end)=0
-       endif
-c$OMP END MASTER
-c-----------------------------------------------------------------------
-c   transformation des tendances physiques en tendances dynamiques:
-c   ---------------------------------------------------------------
-
-c  tendance sur la pression :
-c  -----------------------------------
-      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
-c
-c   62. enthalpie potentielle
-c   ---------------------
-      
-      kstart=1
-      kend=klon
-
-      if (is_north_pole) kstart=2
-      if (is_south_pole)  kend=klon-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-        do ig0=kstart,kend
-          i=index_i(ig0)
-          j=index_j(ig0)
-          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
-          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
-         enddo          
-
-        if (is_north_pole) then
-            DO i=1,iip1
-              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
-            enddo
-        endif
-        
-        if (is_south_pole) then
-            DO i=1,iip1
-              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
-            ENDDO
-        endif
-      ENDDO
-c$OMP END DO NOWAIT
-      
-c   62. humidite specifique
-c   ---------------------
-! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
-!      DO iq=1,nqtot
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!         DO l=1,llm
-!!!cdir NODEP 
-!           do ig0=kstart,kend
-!             i=index_i(ig0)
-!             j=index_j(ig0)
-!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
-!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
-!           enddo
-!           
-!           if (is_north_pole) then
-!             do i=1,iip1
-!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
-!             enddo
-!           endif
-!           
-!           if (is_south_pole) then
-!             do i=1,iip1
-!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
-!             enddo
-!           endif
-!         ENDDO
-!c$OMP END DO NOWAIT
-!      ENDDO
-
-c   63. traceurs
-c   ------------
-C     initialisation des tendances
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        pdqfi(:,:,l,:)=0.
-      ENDDO
-c$OMP END DO NOWAIT	 
-
-C
-!cdir NODEP
-      DO iq=1,nqtot
-         iiq=niadv(iq)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP           
-	     DO ig0=kstart,kend
-              i=index_i(ig0)
-              j=index_j(ig0)
-              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
-              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
-            ENDDO
-	    
-	    IF (is_north_pole) then
-	      DO i=1,iip1
-                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
-	      ENDDO
-	    ENDIF
-	    
-	    IF (is_south_pole) then
-	      DO i=1,iip1
-                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
-	      ENDDO
-	    ENDIF
-	    
-         ENDDO
-c$OMP END DO NOWAIT	 
-      ENDDO
-      
-c   65. champ u:
-c   ------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-         do ig0=kstart,kend
-           i=index_i(ig0)
-           j=index_j(ig0)
-           
-           if (i/=iim) then
-             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
-           endif
-           
-           if (i==1) then
-              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
-     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
-             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
-           endif
-         
-         enddo
-         
-         if (is_north_pole) then
-           DO i=1,iip1
-            pdufi(i,1,l)    = 0.
-           ENDDO
-         endif
-         
-         if (is_south_pole) then
-           DO i=1,iip1
-            pdufi(i,jjp1,l) = 0.
-           ENDDO
-         endif
-         
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   67. champ v:
-c   ------------
-
-      kstart=1
-      kend=klon
-
-      if (is_north_pole) kstart=2
-      if (is_south_pole)  kend=klon-1-iim
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-!CDIR ON_ADB(index_i)
-!CDIR ON_ADB(index_j) 
-!cdir NODEP
-        do ig0=kstart,kend
-           i=index_i(ig0)
-           j=index_j(ig0)
-           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
-           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
-     $	                                    zdvfi2(ig0+iim,l))
-     $				          *cv(i,j)
-        enddo
-         
-      ENDDO
-c$OMP END DO NOWAIT
-
-
-c   68. champ v pres des poles:
-c   ---------------------------
-c      v = U * cos(long) + V * SIN(long)
-
-      if (is_north_pole) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        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,1,l)=
-     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
-          ENDDO
-
-          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
-
-        ENDDO
-c$OMP END DO NOWAIT
-
-      endif    
-      
-      if (is_south_pole) then
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-         DO l=1,llm
-  
-           DO i=1,iim
-              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
-     $        +zdvfi(klon,l)*SIN(rlonv(i))
-
-              pdvfi(i,jjm,l)=
-     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
-           ENDDO
-
-           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
-
-        ENDDO
-c$OMP END DO NOWAIT
-     
-      endif
-c-----------------------------------------------------------------------
-
-700   CONTINUE
- 
-      firstcal = .FALSE.
-
-#else 
-      write(lunout,*) 
-     & "calfis_p: for now can only work with parallel physics" 
-      stop 
-#endif 
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dpar/covcont_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/covcont_p.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/covcont_p.F	(revision 2298)
@@ -1,4 +1,5 @@
       SUBROUTINE covcont_p (klevel,ucov, vcov, ucont, vcont )
-      USE parallel_lmdz
+      USE parallel_lmdz, ONLY: ij_begin,ij_end,OMP_CHUNK,
+     &                         pole_nord, pole_sud
       IMPLICIT NONE
 
Index: LMDZ5/branches/testing/libf/dyn3dpar/gcm.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/gcm.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/gcm.F	(revision 2298)
@@ -14,5 +14,7 @@
       USE parallel_lmdz
       USE infotrac
-      USE mod_interface_dyn_phys
+#ifdef CPP_PHYS
+      USE mod_interface_dyn_phys, ONLY: init_interface_dyn_phys
+#endif
       USE mod_hallo
       USE Bands
Index: LMDZ5/branches/testing/libf/dyn3dpar/gr_dyn_fi_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/gr_dyn_fi_p.F	(revision 2274)
+++ 	(revision )
@@ -1,44 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-      USE mod_interface_dyn_phys
-      USE dimphy
-      USE parallel_lmdz
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ig,l
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-c      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
-c   traitement des poles
-c   traitement des point normaux
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,nfield    
-       DO ig=1,klon
-         i=index_i(ig)
-         j=index_j(ig)
-         pfi(ig,l)=pdyn(i,j,l)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-#endif
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dpar/gr_fi_dyn_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/gr_fi_dyn_p.F	(revision 2274)
+++ 	(revision )
@@ -1,56 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-      USE mod_interface_dyn_phys
-      USE dimphy
-      USE parallel_lmdz
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO ifield=1,nfield
-
-        do ig=1,klon
-          i=index_i(ig)
-          j=index_j(ig)
-          pdyn(i,j,ifield)=pfi(ig,ifield)
-          if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield)
-	enddo
-
-c   traitement des poles
-      if (pole_nord) then
-        do i=1,im
-	  pdyn(i,1,ifield)=pdyn(1,1,ifield)
-	enddo
-      endif
-       
-      if (pole_sud) then
-        do i=1,im
-	  pdyn(i,jm,ifield)=pdyn(1,jm,ifield)
-	enddo
-      endif
-      
-      ENDDO
-c$OMP END DO NOWAIT
-#endif
-! of #ifdef CPP_PHYS
-      RETURN
-      END
Index: LMDZ5/branches/testing/libf/dyn3dpar/leapfrog_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/leapfrog_p.F	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/leapfrog_p.F	(revision 2298)
@@ -825,8 +825,10 @@
 cc$OMP BARRIER
 !        CALL FTRACE_REGION_BEGIN("calfis")
+#ifdef CPP_PHYS
         CALL calfis_p(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  )
+#endif
 !        CALL FTRACE_REGION_END("calfis")
         ijb=ij_begin
Index: LMDZ5/branches/testing/libf/dyn3dpar/mod_hallo.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/mod_hallo.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/mod_hallo.F90	(revision 2298)
@@ -1,4 +1,7 @@
 module mod_Hallo
-USE parallel_lmdz
+USE mod_const_mpi, ONLY: COMM_LMDZ,MPI_REAL_LMDZ
+USE parallel_lmdz, ONLY: using_mpi, mpi_size, mpi_rank, omp_chunk, omp_rank, &
+                         pole_nord, pole_sud, jj_begin, jj_end, &
+                         jj_begin_para, jj_end_para
 implicit none
   logical,save :: use_mpi_alloc
Index: LMDZ5/branches/testing/libf/dyn3dpar/mod_interface_dyn_phys.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/mod_interface_dyn_phys.F90	(revision 2274)
+++ 	(revision )
@@ -1,58 +1,0 @@
-! 
-! $Id$
-!
-MODULE mod_interface_dyn_phys
-  INTEGER,SAVE,dimension(:),allocatable :: index_i
-  INTEGER,SAVE,dimension(:),allocatable :: index_j
-  
-  
-#ifdef CPP_PHYS
-! Interface with parallel physics,
-CONTAINS
-  
-  SUBROUTINE Init_interface_dyn_phys
-    USE mod_phys_lmdz_mpi_data
-    IMPLICIT NONE
-    include 'dimensions.h'    
-    
-    INTEGER :: i,j,k
-    
-    ALLOCATE(index_i(klon_mpi))
-    ALLOCATE(index_j(klon_mpi))
-    
-    k=1
-    IF (is_north_pole) THEN
-      index_i(k)=1
-      index_j(k)=1
-      k=2
-    ELSE
-      DO i=ii_begin,iim
-	index_i(k)=i
-	index_j(k)=jj_begin
-	k=k+1
-       ENDDO
-    ENDIF
-    
-    DO j=jj_begin+1,jj_end-1
-      DO i=1,iim
-	index_i(k)=i
-	index_j(k)=j
-	k=k+1
-      ENDDO
-    ENDDO
-    
-    IF (is_south_pole) THEN
-      index_i(k)=1
-      index_j(k)=jj_end
-    ELSE
-      DO i=1,ii_end
-	index_i(k)=i
-	index_j(k)=jj_end
-	k=k+1
-       ENDDO
-    ENDIF
-  
-  END SUBROUTINE Init_interface_dyn_phys 
-#endif
-! of #ifdef CPP_PHYS
-END MODULE mod_interface_dyn_phys
Index: LMDZ5/branches/testing/libf/dyn3dpar/parallel_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/dyn3dpar/parallel_lmdz.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/dyn3dpar/parallel_lmdz.F90	(revision 2298)
@@ -31,4 +31,21 @@
     integer, save :: omp_size  
 !$OMP THREADPRIVATE(omp_rank)
+
+! Ehouarn: add "dummy variables" (which are in dyn3d_mem/parallel_lmdz.F90)
+! so that calfis_loc compiles even if using dyn3dpar
+    integer,save  :: jjb_u
+    integer,save  :: jje_u
+    integer,save  :: jjnb_u
+    integer,save  :: jjb_v
+    integer,save  :: jje_v
+    integer,save  :: jjnb_v    
+
+    integer,save  :: ijb_u
+    integer,save  :: ije_u
+    integer,save  :: ijnb_u    
+    
+    integer,save  :: ijb_v
+    integer,save  :: ije_v
+    integer,save  :: ijnb_v    
 
  contains
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis.F	(revision 2298)
@@ -0,0 +1,666 @@
+!
+! $Id$
+!
+C
+C
+      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)
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+      USE infotrac, ONLY: nqtot, niadv, tname
+      USE control_mod, ONLY: planet_type, nsplit_phys
+ 
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+
+c    Arguments :
+c    -----------
+      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 dynamics grid
+
+      ! 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)
+
+
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL zpsrf(ngridmx)
+      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
+      REAL zphi(ngridmx,llm),zphis(ngridmx)
+c
+      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
+      REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
+c
+      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
+      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
+c
+      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
+      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
+      REAL zdpsrf(ngridmx)
+c
+      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
+c
+      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
+c
+      
+      REAL SSUM
+
+      LOGICAL,SAVE :: firstcal=.true., debut=.true.
+!      REAL rdayvrai
+
+      LOGICAL tracerdyn
+
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+c
+      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
+         STOP
+        ENDIF
+      ELSE
+        debut = .FALSE.
+      ENDIF ! of IF (firstcal)
+
+c
+c
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+       
+      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)
+
+
+c   42. pression intercouches :
+c
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+c
+       unskap   = 1./ kappa
+c
+      DO l = 1, llmp1
+        zplev( 1,l ) = pp(1,1,l)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              zplev( ig0,l ) = pp(i,j,l)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        zplev( ngridmx,l ) = pp(1,jjp1,l)
+      ENDDO
+c
+c
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+
+      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
+
+c   43.bis traceurs
+c   ---------------
+c
+      DO iq=1,nqtot
+          iiq=niadv(iq) 
+         DO l=1,llm
+            zqfi(1,l,iq) = pq(1,1,l,iiq)
+            ig0          = 2
+            DO j=2,jjm
+               DO i = 1, iim
+                  zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
+                  ig0             = ig0 + 1
+               ENDDO
+            ENDDO
+            zqfi(ig0,l,iq) = pq(1,jjp1,l,iiq)
+         ENDDO
+      ENDDO
+
+c   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")
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+      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
+
+c   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
+c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux 
+c    de masse est calclue dans advtrac.F  
+c      DO l=1,llm
+c        pvervel(1,l)=pw(1,1,l) * g /apoln
+c        ig0=2
+c       DO j=2,jjm
+c           DO i = 1, iim
+c              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
+c              ig0 = ig0 + 1
+c           ENDDO
+c       ENDDO
+c        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
+c      ENDDO
+
+c
+c   45. champ u:
+c   ------------
+
+      DO 50 l=1,llm
+
+         DO 25 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 10 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) )
+10         CONTINUE
+25      CONTINUE
+
+50    CONTINUE
+
+
+c   46.champ v:
+c   -----------
+
+      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
+         ENDDO
+      ENDDO
+
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        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
+
+      ENDDO
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        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
+
+      ENDDO
+c
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+
+!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+      zdt_split=dtphys/nsplit_phys
+      zdufic(:,:)=0.
+      zdvfic(:,:)=0.
+      zdtfic(:,:)=0.
+      zdqfic(:,:,:)=0.
+
+#ifdef CPP_PHYS
+
+       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 physiq (ngridmx,
+     .             llm,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_split,
+     .             zdt_split,
+     .             zplev,
+     .             zplay,
+     .             zphi,
+     .             zphis,
+     .             presnivs,
+     .             zufi,
+     .             zvfi,
+     .             ztfi,
+     .             zqfi,
+     .             flxwfi,
+     .             zdufi,
+     .             zdvfi,
+     .             zdtfi,
+     .             zdqfi,
+     .             zdpsrf,
+     .             pducov)
+
+      else if ( planet_type=="generic" ) then
+
+         CALL physiq (ngridmx,     !! ngrid
+     .             llm,            !! nlayer
+     .             nqtot,          !! nq
+     .             tname,          !! 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
+
+#endif
+! of #ifdef CPP_PHYS
+
+      zdufi(:,:)=zdufic(:,:)/nsplit_phys
+      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
+      zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
+      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
+
+
+500   CONTINUE
+
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
+c
+c   62. enthalpie potentielle
+c   ---------------------
+
+      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
+
+
+c   62. humidite specifique
+c   ---------------------
+! 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
+
+c   63. traceurs
+c   ------------
+C     initialisation des tendances
+      pdqfi(:,:,:,:)=0.
+C
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+         DO l=1,llm
+            DO i=1,iip1
+               pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
+               pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq)
+            ENDDO
+            DO j=2,jjm
+               ig0=1+(j-2)*iim
+               DO i=1,iim
+                  pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq)
+               ENDDO
+               pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq)
+            ENDDO
+         ENDDO
+      ENDDO
+
+c   65. champ u:
+c   ------------
+
+      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
+
+
+c   67. champ v:
+c   ------------
+
+      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
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      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
+
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_loc.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_loc.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_loc.F	(revision 2298)
@@ -0,0 +1,1193 @@
+!
+! $Id$
+!
+C
+C
+      SUBROUTINE calfis_loc(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)
+#ifdef CPP_PHYS
+! If using physics
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+      USE dimphy
+      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
+      USE mod_interface_dyn_phys
+      USE IOPHY
+#endif
+#ifdef CPP_PARA
+      USE parallel_lmdz,ONLY:omp_chunk,using_mpi,jjb_u,jje_u,jjb_v,jje_v
+      USE Write_Field
+      Use Write_field_p
+      USE Times
+#endif
+      USE infotrac, ONLY: nqtot, niadv, tname
+      USE control_mod, ONLY: planet_type, nsplit_phys
+
+#ifdef CPP_PARA
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       ecritphy        frequence d'ecriture (en jours)de histphy
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+c    Arguments :
+c    -----------
+      LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
+      REAL,INTENT(IN):: jD_cur, jH_cur
+      REAL,INTENT(IN):: pvcov(iip1,jjb_v:jje_v,llm) ! covariant meridional velocity
+      REAL,INTENT(IN):: pucov(iip1,jjb_u:jje_u,llm) ! covariant zonal velocity
+      REAL,INTENT(IN):: pteta(iip1,jjb_u:jje_u,llm) ! potential temperature
+      REAL,INTENT(IN):: pmasse(iip1,jjb_u:jje_u,llm) ! mass in each cell ! not used
+      REAL,INTENT(IN):: pq(iip1,jjb_u:jje_u,llm,nqtot) ! tracers
+      REAL,INTENT(IN):: pphis(iip1,jjb_u:jje_u) ! surface geopotential
+      REAL,INTENT(IN):: pphi(iip1,jjb_u:jje_u,llm) ! geopotential
+
+      REAL,INTENT(IN) :: pdvcov(iip1,jjb_v:jje_v,llm) ! dynamical tendency on vcov ! not used
+      REAL,INTENT(IN) :: pducov(iip1,jjb_u:jje_u,llm) ! dynamical tendency on ucov
+      REAL,INTENT(IN) :: pdteta(iip1,jjb_u:jje_u,llm) ! dynamical tendency on teta ! not used
+      REAL,INTENT(IN) :: pdq(iip1,jjb_u:jje_u,llm,nqtot) ! dynamical tendency on tracers ! not used
+
+      REAL,INTENT(IN) :: pps(iip1,jjb_u:jje_u) ! surface pressure (Pa)
+      REAL,INTENT(IN) :: pp(iip1,jjb_u:jje_u,llmp1) ! pressure at mesh interfaces (Pa)
+      REAL,INTENT(IN) :: ppk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: flxw(iip1,jjb_u:jje_u,llm)  ! Vertical mass flux on dynamics grid
+
+      ! tendencies (in */s) from the physics
+      REAL,INTENT(OUT) :: pdvfi(iip1,jjb_v:jje_v,llm) ! tendency on covariant meridional wind
+      REAL,INTENT(OUT) :: pdufi(iip1,jjb_u:jje_u,llm) ! tendency on covariant zonal wind
+      REAL,INTENT(OUT) :: pdhfi(iip1,jjb_u:jje_u,llm) ! tendency on potential temperature (K/s)
+      REAL,INTENT(OUT) :: pdqfi(iip1,jjb_u:jje_u,llm,nqtot) ! tendency on tracers
+      REAL,INTENT(OUT) :: pdpsfi(iip1,jjb_u:jje_u) ! tendency on surface pressure (Pa/s)
+
+#ifdef CPP_PHYS
+! Ehouarn: for now calfis_p needs some informations from physics to compile
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
+      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
+c
+      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
+      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
+
+c
+      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
+      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
+      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
+      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Introduction du splitting (FH)
+! Question pour Yann :
+! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
+! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
+! soit allocatable (plutot par exemple que de passer une dimension
+! dépendant du process en argument des routines) et que, du coup,
+! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
+! Tu confirmes ?
+! J'ai suivi le même principe pour les zdufic_omp
+! Mais c'est surement bien que tu controles.
+! 
+
+      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
+      REAL jH_cur_split,zdt_split
+      LOGICAL debut_split,lafin_split
+      INTEGER isplit
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
+c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
+c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
+c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
+c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
+
+      LOGICAL,SAVE :: first_omp=.true.
+c$OMP THREADPRIVATE(first_omp)
+      
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+c
+      REAL SSUM
+
+      LOGICAL,SAVE :: firstcal=.true., debut=.true.
+c$OMP THREADPRIVATE(firstcal,debut)
+      
+      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
+      INTEGER :: ierr
+#ifdef CPP_MPI
+      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER,dimension(1,4) :: Status
+#endif
+      INTEGER, dimension(4) :: Req
+      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
+      integer :: k,kstart,kend
+      INTEGER :: offset
+
+      LOGICAL tracerdyn  
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      klon=klon_mpi
+      
+c
+      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
+          STOP
+        ENDIF
+c$OMP MASTER
+      ALLOCATE(zpsrf(klon))
+      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
+      ALLOCATE(zphi(klon,llm),zphis(klon))
+      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
+      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
+      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
+      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
+      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
+      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
+      ALLOCATE(zdpsrf(klon))
+      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
+      ALLOCATE(flxwfi(klon,llm))
+c$OMP END MASTER
+c$OMP BARRIER	  
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+c
+c
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+c$OMP MASTER
+      call start_timer(timer_physic)
+c$OMP END MASTER
+
+c$OMP MASTER             
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+      do ig0=1,klon
+        i=index_i(ig0)
+        j=index_j(ig0)
+        zpsrf(ig0)=pps(i,j)
+      enddo
+c$OMP END MASTER
+
+
+c   42. pression intercouches :
+c
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+c
+       unskap   = 1./ kappa
+c
+c      print *,omp_rank,'klon--->',klon
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llmp1
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zplev( ig0,l ) = pp(i,j,l)
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+        enddo
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   43.bis traceurs
+c   ---------------
+c
+
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zphi(ig0,l)  = pphi(i,j,l)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+
+c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
+
+c$OMP MASTER
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zphis(ig0)  = pphis(i,j)
+           enddo
+c$OMP END MASTER
+
+
+c      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
+
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+	 DO ig=1,klon
+	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
+	 ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+
+c
+c   45. champ u:
+c   ------------
+
+      kstart=1
+      kend=klon
+      
+      if (is_north_pole) kstart=2
+      if (is_south_pole) kend=klon-1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!CDIR SPARSE
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          if (i==1) then
+            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
+     $                         + pucov(1,j,l)/cu(1,j) )
+          else
+            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
+     $                       + pucov(i,j,l)/cu(i,j) )
+          endif
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   46.champ v:
+c   -----------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        DO ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
+     $                       + pvcov(i,j,l)/cv(i,j) )
+    
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_north_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+
+           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+           DO i=2,iim
+              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+           ENDDO
+  
+           DO i=1,iim
+              zcos(i)   = COS(rlonv(i))*z1(i)
+              zsin(i)   = SIN(rlonv(i))*z1(i)
+           ENDDO
+  
+           zufi(1,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+  
+        ENDDO
+c$OMP END DO NOWAIT      
+      endif
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_south_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+  
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+           DO i=2,iim
+             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+	   ENDDO
+  
+           DO i=1,iim
+              zcos(i)    = COS(rlonv(i))*z1(i)
+              zsin(i)    = SIN(rlonv(i))*z1(i)
+	   ENDDO
+  
+           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
+        ENDDO
+c$OMP END DO NOWAIT       
+      endif
+
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             flxwfi(ig0,l)  = flxw(i,j,l)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT
+
+c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+c$OMP BARRIER
+      if (first_omp) then
+        klon=klon_omp
+
+        allocate(zplev_omp(klon,llm+1))
+        allocate(zplay_omp(klon,llm))
+        allocate(zphi_omp(klon,llm))
+        allocate(zphis_omp(klon))
+        allocate(presnivs_omp(llm))
+        allocate(zufi_omp(klon,llm))
+        allocate(zvfi_omp(klon,llm))
+        allocate(ztfi_omp(klon,llm))
+        allocate(zqfi_omp(klon,llm,nqtot))
+        allocate(zdufi_omp(klon,llm))
+        allocate(zdvfi_omp(klon,llm))
+        allocate(zdtfi_omp(klon,llm))
+        allocate(zdqfi_omp(klon,llm,nqtot))
+        allocate(zdufic_omp(klon,llm))
+        allocate(zdvfic_omp(klon,llm))
+        allocate(zdtfic_omp(klon,llm))
+        allocate(zdqfic_omp(klon,llm,nqtot))
+        allocate(zdpsrf_omp(klon))
+        allocate(flxwfi_omp(klon,llm))
+	first_omp=.false.
+      endif
+       
+	   
+      klon=klon_omp
+      offset=klon_omp_begin-1
+      
+      do l=1,llm+1
+        do i=1,klon
+          zplev_omp(i,l)=zplev(offset+i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay_omp(i,l)=zplay(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi_omp(i,l)=zphi(offset+i,l)
+	enddo 
+      enddo
+	
+      do i=1,klon
+	zphis_omp(i)=zphis(offset+i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs_omp(l)=presnivs(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi_omp(i,l)=zufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi_omp(i,l)=zvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi_omp(i,l)=ztfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi_omp(i,l)=zdufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi_omp(i,l)=zdtfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf_omp(i)=zdpsrf(offset+i)
+      enddo 
+
+      do l=1,llm
+        do i=1,klon
+          flxwfi_omp(i,l)=flxwfi(offset+i,l)
+	enddo 
+      enddo
+      
+c$OMP BARRIER
+      
+
+!$OMP MASTER 
+!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys 
+!$OMP END MASTER
+      zdt_split=dtphys/nsplit_phys
+      zdufic_omp(:,:)=0.
+      zdvfic_omp(:,:)=0.
+      zdtfic_omp(:,:)=0.
+      zdqfic_omp(:,:,:)=0.
+
+#ifdef CPP_PHYS
+      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 physiq (klon,
+     .             llm,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_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,
+     .             pducov)
+
+      else if ( planet_type=="generic" ) then
+
+      CALL physiq (klon,     !! ngrid
+     .             llm,            !! nlayer
+     .             nqtot,          !! nq
+     .             tname,          !! tracer names from dynamical core (given in infotrac)
+     .             debut_split,    !! firstcall 
+     .             lafin_split,    !! lastcall
+     .             jD_cur,         !! pday. see leapfrog_p 
+     .             jH_cur_split,   !! ptime "fraction of day"
+     .             zdt_split,      !! ptimestep
+     .             zplev_omp,  !! pplev
+     .             zplay_omp,  !! pplay
+     .             zphi_omp,   !! pphi
+     .             zufi_omp,   !! pu
+     .             zvfi_omp,   !! pv
+     .             ztfi_omp,   !! pt
+     .             zqfi_omp,   !! pq
+     .             flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+     .             zdufi_omp,  !! pdu
+     .             zdvfi_omp,  !! pdv
+     .             zdtfi_omp,  !! pdt
+     .             zdqfi_omp,  !! pdq
+     .             zdpsrf_omp, !! pdpsrf
+     .             tracerdyn)      !! tracerdyn <-- utilite ???
+
+      endif ! of if (planet_type=="earth")
+
+
+         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
+         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
+         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
+         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
+
+         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
+         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
+         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
+         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
+
+      enddo
+
+#endif
+! of #ifdef CPP_PHYS
+
+
+      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
+      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
+      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
+      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
+
+c$OMP BARRIER
+
+      do l=1,llm+1
+        do i=1,klon
+          zplev(offset+i,l)=zplev_omp(i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay(offset+i,l)=zplay_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi(offset+i,l)=zphi_omp(i,l)
+	enddo 
+      enddo
+	
+
+      do i=1,klon
+	zphis(offset+i)=zphis_omp(i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs(l)=presnivs_omp(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi(offset+i,l)=zufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi(offset+i,l)=zvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi(offset+i,l)=ztfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi(offset+i,l)=zdufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi(offset+i,l)=zdtfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf(offset+i)=zdpsrf_omp(i)
+      enddo 
+      
+
+      klon=klon_mpi
+500   CONTINUE
+c$OMP BARRIER
+
+c$OMP MASTER
+      call stop_timer(timer_physic)
+c$OMP END MASTER
+
+      IF (using_mpi) THEN
+            
+      if (MPI_rank>0) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+       DO l=1,llm      
+        du_send(1:iim,l)=zdufi(1:iim,l)
+        dv_send(1:iim,l)=zdvfi(1:iim,l)
+       ENDDO
+c$OMP END DO NOWAIT       
+
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER
+!$OMP CRITICAL (MPI)
+        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
+     &                   COMM_LMDZ,Req(1),ierr)
+        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
+     &                  COMM_LMDZ,Req(2),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+c$OMP BARRIER
+     
+      endif
+   
+      if (MPI_rank<MPI_Size-1) then
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER      
+!$OMP CRITICAL (MPI)
+        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
+     &                 COMM_LMDZ,Req(3),ierr)
+        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
+     &                 COMM_LMDZ,Req(4),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+      endif
+
+c$OMP BARRIER
+
+
+#ifdef CPP_MPI 
+c$OMP MASTER    
+!$OMP CRITICAL (MPI)
+      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
+        call MPI_WAITALL(4,Req(1),Status,ierr)
+      else if (MPI_rank>0) then
+        call MPI_WAITALL(2,Req(1),Status,ierr)
+      else if (MPI_rank <MPI_Size-1) then
+        call MPI_WAITALL(2,Req(3),Status,ierr)
+      endif
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+
+c$OMP BARRIER     
+
+      ENDIF ! using_mpi
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            
+        zdufi2(1:klon,l)=zdufi(1:klon,l)
+        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
+            
+        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
+        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
+
+        pdhfi(:,jj_begin,l)=0
+        pdqfi(:,jj_begin,l,:)=0
+        pdufi(:,jj_begin,l)=0
+        pdvfi(:,jj_begin,l)=0
+                
+        if (.not. is_south_pole) then
+          pdhfi(:,jj_end:jj_end+1,l)=0
+          pdqfi(:,jj_end:jj_end+1,l,:)=0
+          pdufi(:,jj_end:jj_end+1,l)=0
+          pdvfi(:,jj_end:jj_end+1,l)=0
+        endif
+      
+       ENDDO 
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+        pdpsfi(:,jj_begin)=0    
+       
+       if (.not. is_south_pole) then
+	 pdpsfi(:,jj_end:jj_end+1)=0
+       endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+c      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
+
+c$OMP MASTER
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pdpsfi(i,j) = zdpsrf(ig0)
+          if (i==1) pdpsfi(iip1,j) =  zdpsrf(ig0)
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+              pdpsfi(i,1)    = zdpsrf(1)
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+              pdpsfi(i,jjp1) = zdpsrf(klon)
+            ENDDO
+        endif
+c$OMP END MASTER
+cc$OMP BARRIER
+
+c
+c   62. enthalpie potentielle
+c   ---------------------
+      
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
+          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
+            ENDDO
+        endif
+      ENDDO
+c$OMP END DO NOWAIT
+      
+c   62. humidite specifique
+c   ---------------------
+! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+!      DO iq=1,nqtot
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!         DO l=1,llm
+!!!cdir NODEP 
+!           do ig0=kstart,kend
+!             i=index_i(ig0)
+!             j=index_j(ig0)
+!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
+!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
+!           enddo
+!           
+!           if (is_north_pole) then
+!             do i=1,iip1
+!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
+!             enddo
+!           endif
+!           
+!           if (is_south_pole) then
+!             do i=1,iip1
+!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
+!             enddo
+!           endif
+!         ENDDO
+!c$OMP END DO NOWAIT
+!      ENDDO
+
+c   63. traceurs
+c   ------------
+C     initialisation des tendances
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        pdqfi(:,jj_begin:jj_end,l,:)=0.
+      ENDDO
+c$OMP END DO NOWAIT	 
+
+C
+!cdir NODEP
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP           
+	     DO ig0=kstart,kend
+              i=index_i(ig0)
+              j=index_j(ig0)
+              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
+              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
+            ENDDO
+	    
+	    IF (is_north_pole) then
+	      DO i=1,iip1
+                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+	    IF (is_south_pole) then
+	      DO i=1,iip1
+                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+      
+c   65. champ u:
+c   ------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+         do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           
+           if (i/=iim) then
+             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+           
+           if (i==1) then
+              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
+     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
+             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+         
+         enddo
+         
+         if (is_north_pole) then
+           DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+           ENDDO
+         endif
+         
+         if (is_south_pole) then
+           DO i=1,iip1
+            pdufi(i,jjp1,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   67. champ v:
+c   ------------
+
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1-iim
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
+           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
+     $	                                    zdvfi2(ig0+iim,l))
+     $				          *cv(i,j)
+        enddo
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      if (is_north_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        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,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+          ENDDO
+
+          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+
+      endif    
+      
+      if (is_south_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+         DO l=1,llm
+  
+           DO i=1,iim
+              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
+     $        +zdvfi(klon,l)*SIN(rlonv(i))
+
+              pdvfi(i,jjm,l)=
+     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
+           ENDDO
+
+           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+     
+      endif
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+#else 
+      write(lunout,*) 
+     & "calfis_p: for now can only work with parallel physics" 
+      stop 
+#endif 
+! of #ifdef CPP_PHYS
+#endif
+! of #ifdef CPP_PARA
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_p.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/calfis_p.F	(revision 2298)
@@ -0,0 +1,1121 @@
+!
+! $Id$
+!
+C
+C
+      SUBROUTINE calfis_p(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)
+#ifdef CPP_PHYS
+! If using physics
+      USE dimphy
+      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
+      USE mod_interface_dyn_phys
+      USE IOPHY
+#endif
+#ifdef CPP_PARA
+      USE parallel_lmdz, ONLY : omp_chunk, using_mpi
+      USE Write_Field
+      Use Write_field_p
+      USE Times
+#endif
+      USE infotrac, ONLY: nqtot, niadv, tname
+      USE control_mod, ONLY: planet_type, nsplit_phys
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       ecritphy        frequence d'ecriture (en jours)de histphy
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+c    Arguments :
+c    -----------
+      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 ! not used
+      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 dynamics grid
+
+      ! 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)
+
+#ifdef CPP_PARA
+#ifdef CPP_PHYS
+! Ehouarn: for now calfis_p needs some informations from physics to compile
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
+      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
+c
+      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
+      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
+
+c
+      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
+      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
+      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
+      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Introduction du splitting (FH)
+! Question pour Yann :
+! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
+! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
+! soit allocatable (plutot par exemple que de passer une dimension
+! dépendant du process en argument des routines) et que, du coup,
+! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
+! Tu confirmes ?
+! J'ai suivi le même principe pour les zdufic_omp
+! Mais c'est surement bien que tu controles.
+! 
+
+      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
+      REAL jH_cur_split,zdt_split
+      LOGICAL debut_split,lafin_split
+      INTEGER isplit
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
+c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
+c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
+c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
+c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
+
+      LOGICAL,SAVE :: first_omp=.true.
+c$OMP THREADPRIVATE(first_omp)
+      
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+c
+      REAL SSUM
+
+      LOGICAL,SAVE :: firstcal=.true., debut=.true.
+c$OMP THREADPRIVATE(firstcal,debut)
+      
+      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
+      INTEGER :: ierr
+#ifdef CPP_MPI
+      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER,dimension(1,4) :: Status
+#endif
+      INTEGER, dimension(4) :: Req
+      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
+      integer :: k,kstart,kend
+      INTEGER :: offset  
+
+      LOGICAL tracerdyn
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      klon=klon_mpi
+      
+c
+      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
+         STOP
+        ENDIF
+c$OMP MASTER
+      ALLOCATE(zpsrf(klon))
+      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
+      ALLOCATE(zphi(klon,llm),zphis(klon))
+      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
+      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
+      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
+      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
+      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
+      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
+      ALLOCATE(zdpsrf(klon))
+      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
+      ALLOCATE(flxwfi(klon,llm))
+c$OMP END MASTER
+c$OMP BARRIER	  
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+c
+c
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+c$OMP MASTER
+      call start_timer(timer_physic)
+c$OMP END MASTER
+
+c$OMP MASTER             
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+      do ig0=1,klon
+        i=index_i(ig0)
+        j=index_j(ig0)
+        zpsrf(ig0)=pps(i,j)
+      enddo
+c$OMP END MASTER
+
+
+c   42. pression intercouches :
+c
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+c
+       unskap   = 1./ kappa
+c
+c      print *,omp_rank,'klon--->',klon
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llmp1
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zplev( ig0,l ) = pp(i,j,l)
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+        enddo
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   43.bis traceurs
+c   ---------------
+c
+
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
+
+      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
+
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+	 DO ig=1,klon
+	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
+	 ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+
+c
+c   45. champ u:
+c   ------------
+
+      kstart=1
+      kend=klon
+      
+      if (is_north_pole) kstart=2
+      if (is_south_pole) kend=klon-1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!CDIR SPARSE
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          if (i==1) then
+            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
+     $                         + pucov(1,j,l)/cu(1,j) )
+          else
+            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
+     $                       + pucov(i,j,l)/cu(i,j) )
+          endif
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   46.champ v:
+c   -----------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        DO ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
+     $                       + pvcov(i,j,l)/cv(i,j) )
+    
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_north_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+
+           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+           DO i=2,iim
+              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+           ENDDO
+  
+           DO i=1,iim
+              zcos(i)   = COS(rlonv(i))*z1(i)
+              zsin(i)   = SIN(rlonv(i))*z1(i)
+           ENDDO
+  
+           zufi(1,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+  
+        ENDDO
+c$OMP END DO NOWAIT      
+      endif
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_south_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+  
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+           DO i=2,iim
+             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+	   ENDDO
+  
+           DO i=1,iim
+              zcos(i)    = COS(rlonv(i))*z1(i)
+              zsin(i)    = SIN(rlonv(i))*z1(i)
+	   ENDDO
+  
+           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
+        ENDDO
+c$OMP END DO NOWAIT       
+      endif
+
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+c$OMP BARRIER
+      if (first_omp) then
+        klon=klon_omp
+
+        allocate(zplev_omp(klon,llm+1))
+        allocate(zplay_omp(klon,llm))
+        allocate(zphi_omp(klon,llm))
+        allocate(zphis_omp(klon))
+        allocate(presnivs_omp(llm))
+        allocate(zufi_omp(klon,llm))
+        allocate(zvfi_omp(klon,llm))
+        allocate(ztfi_omp(klon,llm))
+        allocate(zqfi_omp(klon,llm,nqtot))
+        allocate(zdufi_omp(klon,llm))
+        allocate(zdvfi_omp(klon,llm))
+        allocate(zdtfi_omp(klon,llm))
+        allocate(zdqfi_omp(klon,llm,nqtot))
+        allocate(zdufic_omp(klon,llm))
+        allocate(zdvfic_omp(klon,llm))
+        allocate(zdtfic_omp(klon,llm))
+        allocate(zdqfic_omp(klon,llm,nqtot))
+        allocate(zdpsrf_omp(klon))
+        allocate(flxwfi_omp(klon,llm))
+	first_omp=.false.
+      endif
+       
+	   
+      klon=klon_omp
+      offset=klon_omp_begin-1
+      
+      do l=1,llm+1
+        do i=1,klon
+          zplev_omp(i,l)=zplev(offset+i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay_omp(i,l)=zplay(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi_omp(i,l)=zphi(offset+i,l)
+	enddo 
+      enddo
+	
+      do i=1,klon
+	zphis_omp(i)=zphis(offset+i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs_omp(l)=presnivs(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi_omp(i,l)=zufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi_omp(i,l)=zvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi_omp(i,l)=ztfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi_omp(i,l)=zdufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi_omp(i,l)=zdtfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf_omp(i)=zdpsrf(offset+i)
+      enddo 
+
+      do l=1,llm
+        do i=1,klon
+          flxwfi_omp(i,l)=flxwfi(offset+i,l)
+	enddo 
+      enddo
+      
+c$OMP BARRIER
+      
+!$OMP MASTER
+!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+!$OMP END MASTER
+      zdt_split=dtphys/nsplit_phys
+      zdufic_omp(:,:)=0.
+      zdvfic_omp(:,:)=0.
+      zdtfic_omp(:,:)=0.
+      zdqfic_omp(:,:,:)=0.
+
+#ifdef CPP_PHYS
+      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 physiq (klon,
+     .             llm,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_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,
+     .             pducov)
+
+      else if ( planet_type=="generic" ) then
+
+      CALL physiq (klon,     !! ngrid
+     .             llm,            !! nlayer
+     .             nqtot,          !! nq
+     .             tname,          !! tracer names from dynamical core (given in infotrac)
+     .             debut_split,    !! firstcall 
+     .             lafin_split,    !! lastcall
+     .             jD_cur,         !! pday. see leapfrog_p 
+     .             jH_cur_split,   !! ptime "fraction of day"
+     .             zdt_split,      !! ptimestep
+     .             zplev_omp,  !! pplev
+     .             zplay_omp,  !! pplay
+     .             zphi_omp,   !! pphi
+     .             zufi_omp,   !! pu
+     .             zvfi_omp,   !! pv
+     .             ztfi_omp,   !! pt
+     .             zqfi_omp,   !! pq
+     .             flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+     .             zdufi_omp,  !! pdu
+     .             zdvfi_omp,  !! pdv
+     .             zdtfi_omp,  !! pdt
+     .             zdqfi_omp,  !! pdq
+     .             zdpsrf_omp, !! pdpsrf
+     .             tracerdyn)      !! tracerdyn <-- utilite ???
+
+      endif ! of if (planet_type=="earth")
+
+
+         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
+         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
+         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
+         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
+
+         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
+         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
+         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
+         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
+
+      enddo
+
+#endif
+! of #ifdef CPP_PHYS
+
+      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
+      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
+      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
+      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
+c$OMP BARRIER
+
+      do l=1,llm+1
+        do i=1,klon
+          zplev(offset+i,l)=zplev_omp(i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay(offset+i,l)=zplay_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi(offset+i,l)=zphi_omp(i,l)
+	enddo 
+      enddo
+	
+
+      do i=1,klon
+	zphis(offset+i)=zphis_omp(i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs(l)=presnivs_omp(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi(offset+i,l)=zufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi(offset+i,l)=zvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi(offset+i,l)=ztfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi(offset+i,l)=zdufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi(offset+i,l)=zdtfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf(offset+i)=zdpsrf_omp(i)
+      enddo 
+      
+
+      klon=klon_mpi
+500   CONTINUE
+c$OMP BARRIER
+
+c$OMP MASTER
+      call stop_timer(timer_physic)
+c$OMP END MASTER
+
+      IF (using_mpi) THEN
+            
+      if (MPI_rank>0) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+       DO l=1,llm      
+        du_send(1:iim,l)=zdufi(1:iim,l)
+        dv_send(1:iim,l)=zdvfi(1:iim,l)
+       ENDDO
+c$OMP END DO NOWAIT       
+
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER
+!$OMP CRITICAL (MPI)
+        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
+     &                   COMM_LMDZ,Req(1),ierr)
+        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
+     &                  COMM_LMDZ,Req(2),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+c$OMP BARRIER
+     
+      endif
+   
+      if (MPI_rank<MPI_Size-1) then
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER      
+!$OMP CRITICAL (MPI)
+        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
+     &                 COMM_LMDZ,Req(3),ierr)
+        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
+     &                 COMM_LMDZ,Req(4),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+      endif
+
+c$OMP BARRIER
+
+
+#ifdef CPP_MPI 
+c$OMP MASTER    
+!$OMP CRITICAL (MPI)
+      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
+        call MPI_WAITALL(4,Req(1),Status,ierr)
+      else if (MPI_rank>0) then
+        call MPI_WAITALL(2,Req(1),Status,ierr)
+      else if (MPI_rank <MPI_Size-1) then
+        call MPI_WAITALL(2,Req(3),Status,ierr)
+      endif
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+
+c$OMP BARRIER     
+
+      ENDIF ! using_mpi
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            
+        zdufi2(1:klon,l)=zdufi(1:klon,l)
+        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
+            
+        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
+        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
+  
+         pdhfi(:,jj_begin,l)=0
+         pdqfi(:,jj_begin,l,:)=0
+         pdufi(:,jj_begin,l)=0
+         pdvfi(:,jj_begin,l)=0
+         
+         if (.not. is_south_pole) then
+           pdhfi(:,jj_end,l)=0
+           pdqfi(:,jj_end,l,:)=0
+           pdufi(:,jj_end,l)=0
+           pdvfi(:,jj_end,l)=0
+         endif
+      
+       ENDDO 
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+       pdpsfi(:,jj_begin)=0    
+       if (.not. is_south_pole) then
+	 pdpsfi(:,jj_end)=0
+       endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
+c
+c   62. enthalpie potentielle
+c   ---------------------
+      
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
+          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
+            ENDDO
+        endif
+      ENDDO
+c$OMP END DO NOWAIT
+      
+c   62. humidite specifique
+c   ---------------------
+! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+!      DO iq=1,nqtot
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!         DO l=1,llm
+!!!cdir NODEP 
+!           do ig0=kstart,kend
+!             i=index_i(ig0)
+!             j=index_j(ig0)
+!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
+!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
+!           enddo
+!           
+!           if (is_north_pole) then
+!             do i=1,iip1
+!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
+!             enddo
+!           endif
+!           
+!           if (is_south_pole) then
+!             do i=1,iip1
+!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
+!             enddo
+!           endif
+!         ENDDO
+!c$OMP END DO NOWAIT
+!      ENDDO
+
+c   63. traceurs
+c   ------------
+C     initialisation des tendances
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        pdqfi(:,:,l,:)=0.
+      ENDDO
+c$OMP END DO NOWAIT	 
+
+C
+!cdir NODEP
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP           
+	     DO ig0=kstart,kend
+              i=index_i(ig0)
+              j=index_j(ig0)
+              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
+              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
+            ENDDO
+	    
+	    IF (is_north_pole) then
+	      DO i=1,iip1
+                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+	    IF (is_south_pole) then
+	      DO i=1,iip1
+                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+      
+c   65. champ u:
+c   ------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+         do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           
+           if (i/=iim) then
+             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+           
+           if (i==1) then
+              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
+     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
+             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+         
+         enddo
+         
+         if (is_north_pole) then
+           DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+           ENDDO
+         endif
+         
+         if (is_south_pole) then
+           DO i=1,iip1
+            pdufi(i,jjp1,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   67. champ v:
+c   ------------
+
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1-iim
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
+           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
+     $	                                    zdvfi2(ig0+iim,l))
+     $				          *cv(i,j)
+        enddo
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      if (is_north_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        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,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+          ENDDO
+
+          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+
+      endif    
+      
+      if (is_south_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+         DO l=1,llm
+  
+           DO i=1,iim
+              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
+     $        +zdvfi(klon,l)*SIN(rlonv(i))
+
+              pdvfi(i,jjm,l)=
+     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
+           ENDDO
+
+           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+     
+      endif
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+#else 
+      write(lunout,*) 
+     & "calfis_p: for now can only work with parallel physics" 
+      stop 
+#endif 
+! of #ifdef CPP_PHYS
+#endif
+! of #ifdef CPP_PARA
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi.F	(revision 2298)
@@ -0,0 +1,38 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
+      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
+
+c   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: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi_p.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_dyn_fi_p.F	(revision 2298)
@@ -0,0 +1,44 @@
+!
+! $Id$
+!
+      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
+#ifdef CPP_PARA
+! Interface with parallel physics,
+      USE mod_interface_dyn_phys
+      USE dimphy
+      USE parallel_lmdz
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ig,l
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+c      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+c   traitement des point normaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,nfield    
+       DO ig=1,klon
+         i=index_i(ig)
+         j=index_j(ig)
+         pfi(ig,l)=pdyn(i,j,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+! of #ifdef CPP_PARA
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn.F	(revision 2298)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      DO ifield=1,nfield
+c   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+
+c   traitement des point normaux
+         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
+
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn_p.F
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn_p.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/gr_fi_dyn_p.F	(revision 2298)
@@ -0,0 +1,56 @@
+!
+! $Id$
+!
+      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
+#ifdef CPP_PARA
+! Interface with parallel physics,
+      USE mod_interface_dyn_phys
+      USE dimphy
+      USE parallel_lmdz
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO ifield=1,nfield
+
+        do ig=1,klon
+          i=index_i(ig)
+          j=index_j(ig)
+          pdyn(i,j,ifield)=pfi(ig,ifield)
+          if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield)
+	enddo
+
+c   traitement des poles
+      if (pole_nord) then
+        do i=1,im
+	  pdyn(i,1,ifield)=pdyn(1,1,ifield)
+	enddo
+      endif
+       
+      if (pole_sud) then
+        do i=1,im
+	  pdyn(i,jm,ifield)=pdyn(1,jm,ifield)
+	enddo
+      endif
+      
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+! of #ifdef CPP_PARA
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/ioipsl_getin_p_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/ioipsl_getin_p_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/ioipsl_getin_p_mod.F90	(revision 2298)
@@ -0,0 +1,169 @@
+!
+! $Id$
+!
+MODULE ioipsl_getin_p_mod
+! To use getin in a parallel context
+!---------------------------------------------------------------------
+#ifdef CPP_IOIPSL
+USE ioipsl, ONLY: getin
+#else
+USE ioipsl_getincom, ONLY: getin
+#endif
+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 : 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: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_grid_phy_lmdz.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_grid_phy_lmdz.F90	(revision 2298)
@@ -0,0 +1,454 @@
+!
+!$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,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo
+
+  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(iim,jjp1,llm)
+  IMPLICIT NONE
+  INTEGER, INTENT(in) :: iim
+  INTEGER, INTENT(in) :: jjp1
+  INTEGER, INTENT(in) :: llm
+  
+    nbp_lon=iim
+    nbp_lat=jjp1
+    nbp_lev=llm
+    klon_glo=(iim*jjp1)-2*(iim-1)
+  
+  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: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_interface_dyn_phys.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_interface_dyn_phys.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_interface_dyn_phys.F90	(revision 2298)
@@ -0,0 +1,58 @@
+! 
+! $Id$
+!
+MODULE mod_interface_dyn_phys
+  INTEGER,SAVE,dimension(:),allocatable :: index_i
+  INTEGER,SAVE,dimension(:),allocatable :: index_j
+  
+  
+#ifdef CPP_PARA
+! Interface with parallel physics,
+CONTAINS
+  
+  SUBROUTINE Init_interface_dyn_phys
+    USE mod_phys_lmdz_mpi_data
+    IMPLICIT NONE
+    include 'dimensions.h'    
+    
+    INTEGER :: i,j,k
+    
+    ALLOCATE(index_i(klon_mpi))
+    ALLOCATE(index_j(klon_mpi))
+    
+    k=1
+    IF (is_north_pole) THEN
+      index_i(k)=1
+      index_j(k)=1
+      k=2
+    ELSE
+      DO i=ii_begin,iim
+	index_i(k)=i
+	index_j(k)=jj_begin
+	k=k+1
+       ENDDO
+    ENDIF
+    
+    DO j=jj_begin+1,jj_end-1
+      DO i=1,iim
+	index_i(k)=i
+	index_j(k)=j
+	k=k+1
+      ENDDO
+    ENDDO
+    
+    IF (is_south_pole) THEN
+      index_i(k)=1
+      index_j(k)=jj_end
+    ELSE
+      DO i=1,ii_end
+	index_i(k)=i
+	index_j(k)=jj_end
+	k=k+1
+       ENDDO
+    ENDIF
+  
+  END SUBROUTINE Init_interface_dyn_phys 
+#endif
+! of #ifdef CPP_PARA
+END MODULE mod_interface_dyn_phys
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_data.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_data.F90	(revision 2298)
@@ -0,0 +1,203 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_data
+  USE mod_const_mpi
+  
+  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_root
+  LOGICAL,SAVE :: is_mpi_root
+  LOGICAL,SAVE :: is_using_mpi
+  
+  
+  LOGICAL,SAVE :: is_north_pole
+  LOGICAL,SAVE :: is_south_pole
+  INTEGER,SAVE :: COMM_LMDZ_PHY
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+  USE mod_const_mpi, ONLY : COMM_LMDZ
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+    
+    INTEGER :: ierr
+    INTEGER :: klon_glo
+    INTEGER :: i
+    
+#ifdef CPP_MPI
+    is_using_mpi=.TRUE.
+#else
+    is_using_mpi=.FALSE.
+#endif
+    
+    if (iim.eq.1) then
+       klon_glo=1
+    else
+       klon_glo=iim*(jjp1-2)+2
+    endif
+    
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_using_mpi) THEN    
+#ifdef CPP_MPI
+      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
+#endif
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN
+      mpi_root = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN 
+      is_north_pole = .TRUE.
+    ELSE
+      is_north_pole = .FALSE.
+    ENDIF
+    
+    IF (mpi_rank == mpi_size-1) THEN
+      is_south_pole = .TRUE.
+    ELSE
+      is_south_pole = .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:nb_proc-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)+iim-1
+      ENDIF
+
+      jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1
+      ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1
+
+      
+      ij_para_end(i) = klon_mpi_para_end(i)+iim-1
+      jj_para_end(i) = (ij_para_end(i)-1)/iim + 1
+      ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 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
+    
+  END SUBROUTINE Init_phys_lmdz_mpi_data
+
+  SUBROUTINE print_module_data
+  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_root =', mpi_root
+    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
+    WRITE(lunout,*) 'is_north_pole =', is_north_pole
+    WRITE(lunout,*) 'is_south_pole =', is_south_pole
+    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_transfert.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_mpi_transfert.F90	(revision 2298)
@@ -0,0 +1,1902 @@
+!
+!$Header$
+!
+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 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 
+  
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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 , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+    
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_cgen
+
+
+      
+  SUBROUTINE bcast_mpi_igen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_igen
+
+
+
+  
+  SUBROUTINE bcast_mpi_rgen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+    
+  END SUBROUTINE bcast_mpi_rgen
+  
+
+
+
+  SUBROUTINE bcast_mpi_lgen(var,nb)
+    USE mod_phys_lmdz_mpi_data ,  mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE bcast_mpi_lgen
+
+  
+
+  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    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
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
+                      MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_igen
+
+  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    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
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+
+#endif
+
+  END SUBROUTINE scatter_mpi_rgen
+
+  
+  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    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
+      
+#ifdef CPP_MPI
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_lgen  
+
+
+
+
+  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    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
+    
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
+                     MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+                          
+    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 , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    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
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+                          
+    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 , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    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
+    
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+                          
+    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 , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+   
+    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
+
+
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+            
+  END SUBROUTINE reduce_sum_mpi_igen
+  
+  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+
+    IMPLICIT NONE
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    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
+   
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE reduce_sum_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) 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) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) 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) 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) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) 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) 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) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) 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) 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) 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) 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) 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) 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) 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: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_data.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_data.F90	(revision 2298)
@@ -0,0 +1,109 @@
+!
+!$Id$
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_using_omp
+  
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end    
+  
+  INTEGER,SAVE :: klon_omp
+  INTEGER,SAVE :: klon_omp_begin
+  INTEGER,SAVE :: klon_omp_end
+!$OMP  THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end)
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi)
+    USE dimphy
+    IMPLICIT NONE
+    INTEGER, INTENT(in) :: klon_mpi
+
+    INTEGER :: i
+
+    CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data'
+    CHARACTER (LEN=80) :: abort_message
+
+
+#ifdef CPP_OMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef CPP_OMP
+!$OMP MASTER
+        is_using_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_using_omp=.FALSE.
+    omp_size=1
+    omp_rank=0
+#endif
+
+   is_omp_root=.FALSE.
+!$OMP MASTER
+   IF (omp_rank==0) THEN
+     is_omp_root=.TRUE.
+   ELSE
+     abort_message = 'ANORMAL : OMP_MASTER /= 0'
+     CALL abort_gcm (modname,abort_message,1)
+   ENDIF
+!$OMP END MASTER
+
+
+!$OMP MASTER 
+    ALLOCATE(klon_omp_para_nb(0:omp_size-1))
+    ALLOCATE(klon_omp_para_begin(0:omp_size-1))
+    ALLOCATE(klon_omp_para_end(0:omp_size-1))
+    
+    DO i=0,omp_size-1
+      klon_omp_para_nb(i)=klon_mpi/omp_size
+      IF (i<MOD(klon_mpi,omp_size)) klon_omp_para_nb(i)=klon_omp_para_nb(i)+1
+    ENDDO
+    
+    klon_omp_para_begin(0) = 1
+    klon_omp_para_end(0) = klon_omp_para_nb(0)
+    
+    DO i=1,omp_size-1
+      klon_omp_para_begin(i)=klon_omp_para_end(i-1)+1
+      klon_omp_para_end(i)=klon_omp_para_begin(i)+klon_omp_para_nb(i)-1
+    ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+   
+    klon_omp=klon_omp_para_nb(omp_rank)
+    klon_omp_begin=klon_omp_para_begin(omp_rank)
+    klon_omp_end=klon_omp_para_end(omp_rank)
+    
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_omp_data
+
+  SUBROUTINE Print_module_data
+  IMPLICIT NONE
+  INCLUDE "iniprint.h"
+
+!$OMP CRITICAL  
+  WRITE(lunout,*)'--------> TASK ',omp_rank
+  WRITE(lunout,*)'omp_size =',omp_size
+  WRITE(lunout,*)'omp_rank =',omp_rank
+  WRITE(lunout,*)'is_omp_root =',is_omp_root
+  WRITE(lunout,*)'klon_omp_para_nb =',klon_omp_para_nb
+  WRITE(lunout,*)'klon_omp_para_begin =',klon_omp_para_begin
+  WRITE(lunout,*)'klon_omp_para_end =',klon_omp_para_end    
+  WRITE(lunout,*)'klon_omp =',klon_omp
+  WRITE(lunout,*)'klon_omp_begin =',klon_omp_begin
+  WRITE(lunout,*)'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_transfert.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_omp_transfert.F90	(revision 2298)
@@ -0,0 +1,1064 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  PRIVATE
+  
+  INTEGER,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 
+
+
+  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_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 Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r)
+        
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r)
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))       
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r)
+    
+  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
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    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,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_omp,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    REAL,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_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
+
+END MODULE mod_phys_lmdz_omp_transfert
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_para.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_para.F90	(revision 2298)
@@ -0,0 +1,113 @@
+!
+!$Header$
+!
+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(iim,jjp1,nb_proc,distrib)
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+    CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+!$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
+     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
+  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: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_transfert_para.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/mod_phys_lmdz_transfert_para.F90	(revision 2298)
@@ -0,0 +1,1275 @@
+!
+!$Header$
+!
+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 
+
+   
+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  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phydev/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phydev/iniphysiq.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phydev/iniphysiq.F90	(revision 2298)
@@ -0,0 +1,146 @@
+!
+! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
+                     rlatu,rlonv,aire,cu,cv,                             &
+                     prad,pg,pr,pcpp,iflag_phys)
+  USE dimphy, ONLY: klev ! number of atmospheric levels
+  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
+                                        ! (on full grid)
+  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 comgeomphy, ONLY: initcomgeomphy, &
+                        airephy, & ! physics grid area (m2)
+                        cuphy, & ! cu coeff. (u_covariant = cu * u)
+                        cvphy, & ! cv coeff. (v_covariant = cv * v)
+                        rlond, & ! longitudes
+                        rlatd ! latitudes
+  USE comcstphy, ONLY: rradius, & ! planet radius (m)
+                       rr, & ! recuced gas constant: R/molar mass of atm
+                       rg, & ! gravity
+                       rcpp  ! specific heat of the atmosphere
+  USE phyaqua_mod, ONLY: iniaqua
+  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
+  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
+  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes 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
+  CHARACTER (LEN=20) :: modname='iniphysiq'
+  CHARACTER (LEN=80) :: abort_message
+  REAL :: total_area_phy, total_area_dyn
+
+
+  ! global array, on full physics grid:
+  REAL,ALLOCATABLE :: latfi(:)
+  REAL,ALLOCATABLE :: lonfi(:)
+  REAL,ALLOCATABLE :: cufi(:)
+  REAL,ALLOCATABLE :: cvfi(:)
+  REAL,ALLOCATABLE :: airefi(:)
+
+  IF (nlayer.NE.klev) THEN
+    WRITE(lunout,*) 'STOP in ',trim(modname)
+    WRITE(lunout,*) 'Problem with dimensions :'
+    WRITE(lunout,*) 'nlayer     = ',nlayer
+    WRITE(lunout,*) 'klev   = ',klev
+    abort_message = ''
+    CALL abort_gcm (modname,abort_message,1)
+  ENDIF
+
+  !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/))
+  
+  ! Generate global arrays on full physics grid
+  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
+  ALLOCATE(airefi(klon_glo))
+
+    ! North pole
+    latfi(1)=rlatu(1)
+    lonfi(1)=0.
+    cufi(1) = cu(1)
+    cvfi(1) = cv(1)
+    DO j=2,jjm
+      DO i=1,iim
+        latfi((j-2)*iim+1+i)= rlatu(j)
+        lonfi((j-2)*iim+1+i)= rlonv(i)
+        cufi((j-2)*iim+1+i) = cu((j-1)*iim+1+i)
+        cvfi((j-2)*iim+1+i) = cv((j-1)*iim+1+i)
+      ENDDO
+    ENDDO
+    ! South pole
+    latfi(klon_glo)= rlatu(jjm+1)
+    lonfi(klon_glo)= 0.
+    cufi(klon_glo) = cu((iim+1)*jjm+1)
+    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
+
+    ! build airefi(), mesh area on physics grid
+    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
+    ! Poles are single points on physics grid
+    airefi(1)=sum(aire(1:iim,1))
+    airefi(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(1:klon_glo))
+    IF (total_area_dyn/=total_area_phy) THEN
+      WRITE (lunout, *) 'iniphysiq: 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
+
+!$OMP PARALLEL 
+  ! Now generate local lon/lat/cu/cv/area arrays
+  CALL initcomgeomphy
+
+  offset = klon_mpi_begin - 1
+  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
+  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
+  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
+
+  ! copy some fundamental parameters to physics
+  rradius=prad
+  rg=pg
+  rr=pr
+  rcpp=pcpp
+
+!$OMP END PARALLEL
+
+  ! Additional initializations for aquaplanets 
+!$OMP PARALLEL
+  IF (iflag_phys>=100) THEN
+    CALL iniaqua(klon_omp,rlatd,rlond,iflag_phys)
+  ENDIF
+!$OMP END PARALLEL
+
+END SUBROUTINE iniphysiq
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/ce0l.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/ce0l.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/ce0l.F90	(revision 2298)
@@ -0,0 +1,120 @@
+!
+! $Id$
+!
+!-------------------------------------------------------------------------------
+!
+PROGRAM ce0l
+!-------------------------------------------------------------------------------
+! Purpose: Calls etat0, creates initial states and limit_netcdf
+!
+!     interbar=.T. for barycentric interpolation inter_barxy
+!     extrap  =.T. for data extrapolation, like for the SSTs when file does not
+!                  contain ocean points only.
+!     oldice  =.T. for old-style ice, obtained using grille_m (grid_atob).
+!     masque is created in etat0, passed to limit to ensure consistancy.
+!-------------------------------------------------------------------------------
+  USE control_mod
+#ifdef CPP_EARTH
+! This prog. is designed to work for Earth
+  USE dimphy
+  USE comgeomphy
+  USE infotrac
+  USE indice_sol_mod
+
+#ifdef CPP_IOIPSL
+  USE ioipsl, ONLY: ioconf_calendar, getin
+#else
+  ! if not using IOIPSL, we still need to use (a local version of) getin
+  use ioipsl_getincom, only: getin
+#endif
+
+#endif
+  IMPLICIT NONE
+#ifndef CPP_EARTH
+#include "iniprint.h"
+  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
+#else
+!-------------------------------------------------------------------------------
+! Local variables:
+  LOGICAL, PARAMETER :: interbar=.TRUE., extrap=.FALSE., oldice=.FALSE.
+#include "dimensions.h"
+#include "paramet.h"
+!#include "indicesol.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "logic.h"
+  REAL,    DIMENSION(iip1,jjp1) :: masque
+  CHARACTER(LEN=15)             :: calnd
+  REAL,    DIMENSION(iip1,jjp1) :: phis ! geopotentiel au sol
+  logical use_filtre_fft
+!-------------------------------------------------------------------------------
+  CALL conf_gcm( 99, .TRUE. )
+
+  use_filtre_fft=.FALSE.
+  CALL getin('use_filtre_fft',use_filtre_fft)
+  IF (use_filtre_fft) THEN
+     write(lunout, fmt = *) 'FFT filter is not available in the ' &
+          // 'sequential version of the dynamics.'
+     write(lunout, fmt = *) &
+          "Your setting of variable use_filtre_fft is not used."
+  ENDIF
+
+  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+  WRITE(lunout,*)'---> klon=',klon
+  CALL InitComgeomphy
+
+#ifdef CPP_IOIPSL
+  SELECT CASE(calend)
+    CASE('earth_360d');CALL ioconf_calendar('360d');      calnd='a 360 jours/an'
+    CASE('earth_365d');CALL ioconf_calendar('noleap');    calnd='a 365 jours/an'
+    CASE('earth_366d');CALL ioconf_calendar('366d');      calnd='bissextile'
+    CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('standard');  CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('julian');    CALL ioconf_calendar('julian');    calnd='julien'
+    CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian')
+  !--- DC Bof...  => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian
+    CASE DEFAULT
+      CALL abort_gcm('ce0l','Mauvais choix de calendrier',1)
+  END SELECT
+  WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd)
+#endif
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+    CALL init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday)
+    CALL init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
+    WRITE(lunout,*)'nbtr =' , nbtr 
+#endif
+  END IF
+
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  etat0_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) ' interbar = ',interbar
+  CALL etat0_netcdf(interbar,masque,phis,ok_etat0)
+
+  IF(ok_limit) THEN
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  Limit_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  CALL limit_netcdf(interbar,extrap,oldice,masque)
+  END IF
+
+  
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,*) '  ***  grilles_gcm_netcdf ***  '
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,'(//)')
+  CALL grilles_gcm_netcdf_sub(masque,phis)
+
+#endif
+! of #ifndef CPP_EARTH #else
+
+END PROGRAM ce0l
+!
+!-------------------------------------------------------------------------------
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/iniphysiq.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phylmd/iniphysiq.F90	(revision 2298)
@@ -0,0 +1,204 @@
+
+! $Id$
+
+
+SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
+                     rlatu,rlonv,aire,cu,cv,                             &
+                     prad,pg,pr,pcpp,iflag_phys)
+  USE dimphy, ONLY: klev ! number of atmospheric levels
+  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
+                                        ! (on full grid)
+  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 comgeomphy, ONLY: initcomgeomphy, &
+                        airephy, & ! physics grid area (m2)
+                        cuphy, & ! cu coeff. (u_covariant = cu * u)
+                        cvphy, & ! cv coeff. (v_covariant = cv * v)
+                        rlond, & ! longitudes
+                        rlatd ! latitudes
+  USE phyaqua_mod, ONLY: iniaqua
+  IMPLICIT NONE
+
+  ! =======================================================================
+  ! Initialisation of the physical constants and some positional and
+  ! geometrical arrays for the physics
+  ! =======================================================================
+
+  include "YOMCST.h"
+  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 columns along longitudes
+  INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes
+  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
+  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes 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
+  CHARACTER (LEN=20) :: modname = 'iniphysiq'
+  CHARACTER (LEN=80) :: abort_message
+  REAL :: total_area_phy, total_area_dyn
+
+
+  ! global array, on full physics grid:
+  REAL,ALLOCATABLE :: latfi(:)
+  REAL,ALLOCATABLE :: lonfi(:)
+  REAL,ALLOCATABLE :: cufi(:)
+  REAL,ALLOCATABLE :: cvfi(:)
+  REAL,ALLOCATABLE :: airefi(:)
+
+  IF (nlayer/=klev) THEN
+    WRITE (lunout, *) 'STOP in ', trim(modname)
+    WRITE (lunout, *) 'Problem with dimensions :'
+    WRITE (lunout, *) 'nlayer     = ', nlayer
+    WRITE (lunout, *) 'klev   = ', klev
+    abort_message = ''
+    CALL abort_gcm(modname, abort_message, 1)
+  END IF
+
+  !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/))
+  
+  ! Generate global arrays on full physics grid
+  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
+  ALLOCATE(airefi(klon_glo))
+
+  IF (klon_glo>1) THEN ! general case
+    ! North pole
+    latfi(1)=rlatu(1)
+    lonfi(1)=0.
+    cufi(1) = cu(1)
+    cvfi(1) = cv(1)
+    DO j=2,jjm
+      DO i=1,iim
+        latfi((j-2)*iim+1+i)= rlatu(j)
+        lonfi((j-2)*iim+1+i)= rlonv(i)
+        cufi((j-2)*iim+1+i) = cu((j-1)*(iim+1)+i)
+        cvfi((j-2)*iim+1+i) = cv((j-1)*(iim+1)+i)
+      ENDDO
+    ENDDO
+    ! South pole
+    latfi(klon_glo)= rlatu(jjm+1)
+    lonfi(klon_glo)= 0.
+    cufi(klon_glo) = cu((iim+1)*jjm+1)
+    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
+
+    ! build airefi(), mesh area on physics grid
+    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
+    ! Poles are single points on physics grid
+    airefi(1)=sum(aire(1:iim,1))
+    airefi(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(1:klon_glo))
+    IF (total_area_dyn/=total_area_phy) THEN
+      WRITE (lunout, *) 'iniphysiq: 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(1)=rlatu(1)
+    lonfi(1)=rlonv(1)
+    cufi(1)=cu(1)
+    cvfi(1)=cv(1)
+    airefi(1)=aire(1,1)
+  ENDIF ! of IF (klon_glo>1)
+
+!$OMP PARALLEL 
+  ! Now generate local lon/lat/cu/cv/area arrays
+  CALL initcomgeomphy
+
+  offset = klon_mpi_begin - 1
+  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
+  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
+  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
+
+    ! suphel => initialize some physical constants (orbital parameters,
+    !           geoid, gravity, thermodynamical constants, etc.) in the
+    !           physics
+  CALL suphel
+
+!$OMP END PARALLEL
+
+  ! check that physical constants set in 'suphel' are coherent
+  ! with values set in the dynamics:
+  IF (rday/=punjours) THEN
+    WRITE (lunout, *) 'iniphysiq: 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_gcm(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rg/=pg) THEN
+    WRITE (lunout, *) 'iniphysiq: 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_gcm(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (ra/=prad) THEN
+    WRITE (lunout, *) 'iniphysiq: 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_gcm(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rd/=pr) THEN
+    WRITE (lunout, *) 'iniphysiq: 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_gcm(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rcpd/=pcpp) THEN
+    WRITE (lunout, *) 'iniphysiq: 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_gcm(modname, abort_message, 1)
+    END IF
+  END IF
+
+  ! Additional initializations for aquaplanets
+!$OMP PARALLEL
+  IF (iflag_phys>=100) THEN
+    CALL iniaqua(klon_omp, rlatd, rlond, iflag_phys)
+  END IF
+!$OMP END PARALLEL
+
+END SUBROUTINE iniphysiq
Index: LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phymar/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phymar/iniphysiq.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/dynlonlat_phylonlat/phymar/iniphysiq.F90	(revision 2298)
@@ -0,0 +1,157 @@
+!
+! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
+                     rlatu,rlonv,aire,cu,cv,                             &
+                     prad,pg,pr,pcpp,iflag_phys)
+  USE dimphy, ONLY: klev ! number of atmospheric levels
+  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
+                                        ! (on full grid)
+  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 comgeomphy, ONLY: initcomgeomphy, &
+                        airephy, & ! physics grid area (m2)
+                        cuphy, & ! cu coeff. (u_covariant = cu * u)
+                        cvphy, & ! cv coeff. (v_covariant = cv * v)
+                        rlond, & ! longitudes
+                        rlatd ! latitudes
+  USE comcstphy, ONLY: rradius, & ! planet radius (m)
+                       rr, & ! recuced gas constant: R/molar mass of atm
+                       rg, & ! gravity
+                       rcpp  ! specific heat of the atmosphere
+!  USE phyaqua_mod, ONLY: iniaqua
+  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
+  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
+  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes 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
+  CHARACTER (LEN=20) :: modname='iniphysiq'
+  CHARACTER (LEN=80) :: abort_message
+  REAL :: total_area_phy, total_area_dyn
+
+
+  ! global array, on full physics grid:
+  REAL,ALLOCATABLE :: latfi(:)
+  REAL,ALLOCATABLE :: lonfi(:)
+  REAL,ALLOCATABLE :: cufi(:)
+  REAL,ALLOCATABLE :: cvfi(:)
+  REAL,ALLOCATABLE :: airefi(:)
+ 
+  IF (nlayer.NE.klev) THEN
+    WRITE(lunout,*) 'STOP in ',trim(modname)
+    WRITE(lunout,*) 'Problem with dimensions :'
+    WRITE(lunout,*) 'nlayer     = ',nlayer
+    WRITE(lunout,*) 'klev   = ',klev
+    abort_message = ''
+    CALL abort_gcm (modname,abort_message,1)
+  ENDIF
+
+
+  ! Generate global arrays on full physics grid
+  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
+  ALLOCATE(airefi(klon_glo))
+
+  IF (klon_glo>1) THEN ! general case
+    ! North pole
+    latfi(1)=rlatu(1)
+    lonfi(1)=0.
+    cufi(1) = cu(1)
+    cvfi(1) = cv(1)
+    DO j=2,jjm
+      DO i=1,iim
+        latfi((j-2)*iim+1+i)= rlatu(j)
+        lonfi((j-2)*iim+1+i)= rlonv(i)
+        cufi((j-2)*iim+1+i) = cu((j-1)*iim+1+i)
+        cvfi((j-2)*iim+1+i) = cv((j-1)*iim+1+i)
+      ENDDO
+    ENDDO
+    ! South pole
+    latfi(klon_glo)= rlatu(jjm+1)
+    lonfi(klon_glo)= 0.
+    cufi(klon_glo) = cu((iim+1)*jjm+1)
+    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
+
+    ! build airefi(), mesh area on physics grid
+    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
+    ! Poles are single points on physics grid
+    airefi(1)=sum(aire(1:iim,1))
+    airefi(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(1:klon_glo))
+    IF (total_area_dyn/=total_area_phy) THEN
+      WRITE (lunout, *) 'iniphysiq: 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(1)=rlatu(1)
+    lonfi(1)=rlonv(1)
+    cufi(1)=cu(1)
+    cvfi(1)=cv(1)
+    airefi(1)=aire(1,1)
+  ENDIF ! of IF (klon_glo>1)
+
+!$OMP PARALLEL
+  ! Now generate local lon/lat/cu/cv/area arrays
+  CALL initcomgeomphy
+      
+  offset = klon_mpi_begin - 1
+  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
+  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
+  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
+  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
+
+! copy some fundamental parameters to physics
+  rradius=prad
+  rg=pg
+  rr=pr
+  rcpp=pcpp
+
+!$OMP END PARALLEL
+
+!      print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ'
+!      print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...'
+
+! Additional initializations for aquaplanets 
+!!$OMP PARALLEL
+!      if (iflag_phys>=100) then
+!        call iniaqua(klon_omp,rlatd,rlond,iflag_phys)
+!      endif
+!!$OMP END PARALLEL
+
+      END
Index: LMDZ5/branches/testing/libf/grid/dimension/makdim
===================================================================
--- LMDZ5/branches/testing/libf/grid/dimension/makdim	(revision 2274)
+++ LMDZ5/branches/testing/libf/grid/dimension/makdim	(revision 2298)
@@ -12,5 +12,5 @@
 fi
 
-if (($1 % 8 != 0)) && (( $# = 3 ))
+if (($1 % 8 != 0)) && (( $# == 3 ))
 then
     echo "The number of longitudes must be a multiple of 8."
Index: LMDZ5/branches/testing/libf/misc/arth_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/arth_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/arth_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/assert_eq_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/assert_eq_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/assert_eq_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/assert_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/assert_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/assert_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/cbrt.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/cbrt.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/cbrt.F	(revision 2298)
@@ -0,0 +1,11 @@
+      FUNCTION cbrt(x)
+      ! Return the cubic root for positive or negative x
+      IMPLICIT NONE
+
+      REAL x,cbrt
+
+      cbrt=sign(1.,x)*(abs(x)**(1./3.))
+
+      RETURN
+      END
+
Index: LMDZ5/branches/testing/libf/misc/chfev.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/chfev.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/chfev.F	(revision 2298)
@@ -0,0 +1,155 @@
+*DECK CHFEV
+      SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
+C***BEGIN PROLOGUE  CHFEV
+C***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
+C            array of points.  While designed for use by PCHFE, it may
+C            be useful directly as an evaluator for a piecewise cubic
+C            Hermite function in applications, such as graphing, where
+C            the interval is known in advance.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E3
+C***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
+C***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
+C             PCHIP
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          CHFEV:  Cubic Hermite Function EValuator
+C
+C     Evaluates the cubic polynomial determined by function values
+C     F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
+C     XE(J), J=1(1)NE.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        INTEGER  NE, NEXT(2), IERR
+C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
+C
+C        CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
+C
+C   Parameters:
+C
+C     X1,X2 -- (input) endpoints of interval of definition of cubic.
+C           (Error return if  X1.EQ.X2 .)
+C
+C     F1,F2 -- (input) values of function at X1 and X2, respectively.
+C
+C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
+C
+C     NE -- (input) number of evaluation points.  (Error return if
+C           NE.LT.1 .)
+C
+C     XE -- (input) real array of points at which the function is to be
+C           evaluated.  If any of the XE are outside the interval
+C           [X1,X2], a warning error is returned in NEXT.
+C
+C     FE -- (output) real array of values of the cubic function defined
+C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
+C
+C     NEXT -- (output) integer array indicating number of extrapolation
+C           points:
+C            NEXT(1) = number of evaluation points to left of interval.
+C            NEXT(2) = number of evaluation points to right of interval.
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           "Recoverable" errors:
+C              IERR = -1  if NE.LT.1 .
+C              IERR = -2  if X1.EQ.X2 .
+C                (The FE-array has not been changed in either case.)
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   811019  DATE WRITTEN
+C   820803  Minor cosmetic changes for release 1.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890703  Corrected category record.  (WRB)
+C   890703  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  CHFEV
+C  Programming notes:
+C
+C     To produce a double precision version, simply:
+C        a. Change CHFEV to DCHFEV wherever it occurs,
+C        b. Change the real declaration to double precision, and
+C        c. Change the constant ZERO to double precision.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  NE, NEXT(2), IERR
+      REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I
+      REAL  C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
+      SAVE ZERO
+      DATA  ZERO /0./
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  CHFEV
+      IF (NE .LT. 1)  GO TO 5001
+      H = X2 - X1
+      IF (H .EQ. ZERO)  GO TO 5002
+C
+C  INITIALIZE.
+C
+      IERR = 0
+      NEXT(1) = 0
+      NEXT(2) = 0
+      XMI = MIN(ZERO, H)
+      XMA = MAX(ZERO, H)
+C
+C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
+C
+      DELTA = (F2 - F1)/H
+      DEL1 = (D1 - DELTA)/H
+      DEL2 = (D2 - DELTA)/H
+C                                           (DELTA IS NO LONGER NEEDED.)
+      C2 = -(DEL1+DEL1 + DEL2)
+      C3 = (DEL1 + DEL2)/H
+C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
+C
+C  EVALUATION LOOP.
+C
+      DO 500  I = 1, NE
+         X = XE(I) - X1
+         FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
+C          COUNT EXTRAPOLATION POINTS.
+         IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
+         IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
+C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
+  500 CONTINUE
+C
+C  NORMAL RETURN.
+C
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     NE.LT.1 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'CHFEV',
+     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     X1.EQ.X2 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR,
+     +   1)
+      RETURN
+C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
+      END
Index: LMDZ5/branches/testing/libf/misc/coefpoly_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/coefpoly_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/coefpoly_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/cray.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/cray.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/cray.F	(revision 2298)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
+
+      function ssum(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+c
+      ssum=0.
+      ix=1
+      do 10 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+10    continue
+c
+      return
+      end
+#endif
Index: LMDZ5/branches/testing/libf/misc/description.h
===================================================================
--- LMDZ5/branches/testing/libf/misc/description.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/description.h	(revision 2298)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character (len=120) :: descript
+      common /titre/descript
Index: LMDZ5/branches/testing/libf/misc/fdump.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/fdump.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/fdump.F	(revision 2298)
@@ -0,0 +1,31 @@
+*DECK FDUMP
+      SUBROUTINE FDUMP
+C***BEGIN PROLOGUE  FDUMP
+C***PURPOSE  Symbolic dump (should be locally written).
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3
+C***TYPE      ALL (FDUMP-A)
+C***KEYWORDS  ERROR, XERMSG
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C        ***Note*** Machine Dependent Routine
+C        FDUMP is intended to be replaced by a locally written
+C        version which produces a symbolic dump.  Failing this,
+C        it should be replaced by a version which prints the
+C        subprogram nesting list.  Note that this dump must be
+C        printed on each of up to five files, as indicated by the
+C        XGETUA routine.  See XSETUA and XGETUA for details.
+C
+C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  FDUMP
+C***FIRST EXECUTABLE STATEMENT  FDUMP
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/formcoord.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/formcoord.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/formcoord.F	(revision 2298)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      subroutine formcoord(unit,n,x,a,rev,text)
+      implicit none
+      integer n,unit,ndec
+      logical rev
+      real x(n),a
+      character*4 text
+
+      integer i,id,i1,i2,in
+      real dx,dxmin
+
+      if(rev) then
+         id=-1
+         i1=n
+         i2=n-1
+         in=1
+         write(unit,3000) text(1:1)
+      else
+         id=1
+         i1=1
+         i2=2
+         in=n
+      endif
+
+      if (n.lt.2) then
+         ndec=1
+         write(unit,1000) text,n,x(1)*a
+      else
+         dxmin=abs(x(2)-x(1))
+         do i=2,n-1
+            dx=abs(x(i+1)-x(i))
+            if (dx.lt.dxmin) dxmin=dx
+         enddo
+
+         ndec=-log10(dxmin)+2
+         if(mod(n,6).eq.1) then
+            write(unit,1000) text,n,x(i1)*a
+            write(unit,2000) (x(i)*a,i=i2,in,id)
+         else
+            write(unit,1000) text,n
+            write(unit,2000) (x(i)*a,i=i1,in,id)
+         endif
+      endif
+
+1000  format(a4,2x,i4,' LEVELS',43x,f12.2)
+2000  format(6f12.2)
+c1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
+c2000  format(6f12.<ndec>)
+3000  format('FORMAT ',a1,'REV')
+      return
+
+      end
Index: LMDZ5/branches/testing/libf/misc/handle_err_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/handle_err_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/handle_err_m.F90	(revision 2298)
@@ -0,0 +1,46 @@
+! $Id$
+module handle_err_m
+
+  implicit none
+
+contains
+
+  subroutine handle_err(message, ncerr, ncid, varid)
+
+    use netcdf, only: nf90_strerror, nf90_noerr, nf90_close
+
+    character(len=*), intent(in):: message
+    ! (should include name of calling procedure)
+
+    integer, intent(in):: ncerr
+
+    integer, intent(in), optional :: ncid
+    ! (Provide this argument if you want "handle_err" to try to close
+    ! the file.)
+
+    integer, intent(in), optional :: varid
+
+    ! Variable local to the procedure:
+    integer ncerr_close
+
+    !-------------------
+
+    if (ncerr /= nf90_noerr) then
+       print *, message, ":"
+       if (present(varid)) print *, "varid = ", varid
+       print *, trim(nf90_strerror(ncerr))
+       if (present(ncid)) then
+          ! Try to close, to leave the file in a consistent state:
+          ncerr_close = nf90_close(ncid)
+          ! (do not call "nf95_close", we do not want to recurse)
+          if (ncerr_close /= nf90_noerr) then
+             print *, "nf90_close:"
+             print *, trim(nf90_strerror(ncerr_close))
+          end if
+       end if
+       call abort_gcm("NetCDF95 handle_err", "", 1)
+    end if
+
+  end subroutine handle_err
+
+end module handle_err_m
Index: LMDZ5/branches/testing/libf/misc/i1mach.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/i1mach.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/i1mach.F	(revision 2298)
@@ -0,0 +1,128 @@
+*DECK I1MACH
+      INTEGER FUNCTION I1MACH (I)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  I1MACH
+C***PURPOSE  Return integer machine dependent constants.
+C***LIBRARY   SLATEC
+C***CATEGORY  R1
+C***TYPE      INTEGER (I1MACH-I)
+C***KEYWORDS  MACHINE CONSTANTS
+C***AUTHOR  Fox, P. A., (Bell Labs)
+C           Hall, A. D., (Bell Labs)
+C           Schryer, N. L., (Bell Labs)
+C***DESCRIPTION
+C
+C   I1MACH can be used to obtain machine-dependent parameters for the
+C   local machine environment.  It is a function subprogram with one
+C   (input) argument and can be referenced as follows:
+C
+C        K = I1MACH(I)
+C
+C   where I=1,...,16.  The (output) value of K above is determined by
+C   the (input) value of I.  The results for various values of I are
+C   discussed below.
+C
+C   I/O unit numbers:
+C     I1MACH( 1) = the standard input unit.
+C     I1MACH( 2) = the standard output unit.
+C     I1MACH( 3) = the standard punch unit.
+C     I1MACH( 4) = the standard error message unit.
+C
+C   Words:
+C     I1MACH( 5) = the number of bits per integer storage unit.
+C     I1MACH( 6) = the number of characters per integer storage unit.
+C
+C   Integers:
+C     assume integers are represented in the S-digit, base-A form
+C
+C                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
+C
+C                where 0 .LE. X(I) .LT. A for I=0,...,S-1.
+C     I1MACH( 7) = A, the base.
+C     I1MACH( 8) = S, the number of base-A digits.
+C     I1MACH( 9) = A**S - 1, the largest magnitude.
+C
+C   Floating-Point Numbers:
+C     Assume floating-point numbers are represented in the T-digit,
+C     base-B form
+C                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+C
+C                where 0 .LE. X(I) .LT. B for I=1,...,T,
+C                0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
+C     I1MACH(10) = B, the base.
+C
+C   Single-Precision:
+C     I1MACH(11) = T, the number of base-B digits.
+C     I1MACH(12) = EMIN, the smallest exponent E.
+C     I1MACH(13) = EMAX, the largest exponent E.
+C
+C   Double-Precision:
+C     I1MACH(14) = T, the number of base-B digits.
+C     I1MACH(15) = EMIN, the smallest exponent E.
+C     I1MACH(16) = EMAX, the largest exponent E.
+C
+C   To alter this function for a particular environment, the desired
+C   set of DATA statements should be activated by removing the C from
+C   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
+C   checked for consistency with the local operating system.
+C
+C***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
+C                 a portable library, ACM Transactions on Mathematical
+C                 Software 4, 2 (June 1978), pp. 177-188.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   750101  DATE WRITTEN
+C   891012  Added VAX G-floating constants.  (WRB)
+C   891012  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900618  Added DEC RISC constants.  (WRB)
+C   900723  Added IBM RS 6000 constants.  (WRB)
+C   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
+C           (RWC)
+C   910710  Added HP 730 constants.  (SMR)
+C   911114  Added Convex IEEE constants.  (WRB)
+C   920121  Added SUN -r8 compiler option constants.  (WRB)
+C   920229  Added Touchstone Delta i860 constants.  (WRB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C   920625  Added Convex -p8 and -pd8 compiler option constants.
+C           (BKS, WRB)
+C   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
+C   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
+C           options.  (DWL, RWC and WRB).
+C   100623  Use Fortran 95 intrinsic functions (Lionel GUEZ)
+C***END PROLOGUE  I1MACH
+C
+      INTEGER IMACH(16),OUTPUT
+      SAVE IMACH
+      EQUIVALENCE (IMACH(4),OUTPUT)
+      INTEGER I
+C***FIRST EXECUTABLE STATEMENT  I1MACH
+      IMACH( 1) =         5
+      IMACH( 2) =         6
+      IMACH( 3) =         6
+      IMACH( 4) =         6
+      IMACH( 5) =        bit_size(0)
+      IMACH( 6) =         IMACH( 5) / 8
+      IMACH( 7) =         radix(0)
+      IMACH( 8) =        digits(0)
+      IMACH( 9) =     huge(0)
+      IMACH(10) =         radix(0.)
+      IMACH(11) =        digits(0.)
+      IMACH(12) =      minexponent(0.)
+      IMACH(13) =       maxexponent(0.)
+      IMACH(14) =        digits(0d0)
+      IMACH(15) =      minexponent(0d0)
+      IMACH(16) =       maxexponent(0d0)
+      IF (I .LT. 1  .OR.  I .GT. 16) GO TO 10
+C
+      I1MACH = IMACH(I)
+      RETURN
+C
+   10 CONTINUE
+      WRITE (UNIT = OUTPUT, FMT = 9000)
+ 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
+C
+C     CALL FDUMP
+C
+      STOP
+      END
Index: LMDZ5/branches/testing/libf/misc/iniprint.h
===================================================================
--- LMDZ5/branches/testing/libf/misc/iniprint.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/iniprint.h	(revision 2298)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!
+! gestion des impressions de sorties et de débogage
+! lunout:    unité du fichier dans lequel se font les sorties 
+!                           (par defaut 6, la sortie standard)
+! prt_level: niveau d'impression souhaité (0 = minimum)
+!
+      INTEGER lunout, prt_level
+      COMMON /comprint/ lunout, prt_level
Index: LMDZ5/branches/testing/libf/misc/interpolation.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/interpolation.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/interpolation.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/ioipsl_errioipsl.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/ioipsl_errioipsl.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ioipsl_errioipsl.F90	(revision 2298)
@@ -0,0 +1,219 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_errioipsl
+!-
+!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg
+!-
+  INTEGER :: n_l=6, ilv_cur=0, ilv_max=0
+  LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE.
+!-
+!===
+CONTAINS
+!===
+SUBROUTINE ipslnlf (new_number,old_number)
+!!--------------------------------------------------------------------
+!! The "ipslnlf" routine allows to know and modify
+!! the current logical number for the messages.
+!!
+!! SUBROUTINE ipslnlf (new_number,old_number)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_number : new logical number of the file
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_number : current logical number of the file
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(IN)  :: new_number
+  INTEGER,OPTIONAL,INTENT(OUT) :: old_number
+!---------------------------------------------------------------------
+  IF (PRESENT(old_number)) THEN
+    old_number = n_l
+  ENDIF
+  IF (PRESENT(new_number)) THEN
+    n_l = new_number
+  ENDIF
+!---------------------
+END SUBROUTINE ipslnlf
+!===
+SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!! The "ipslerr" routine
+!! allows to handle the messages to the user.
+!!
+!! INPUT
+!!
+!! plev   : Category of message to be reported to the user
+!!          1 = Note to the user
+!!          2 = Warning to the user
+!!          3 = Fatal error
+!! pcname : Name of subroutine which has called ipslerr
+!! pstr1   
+!! pstr2  : Strings containing the explanations to the user
+!! pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     ilv_cur = plev
+     ilv_max = MAX(ilv_max,plev)
+     WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
+   ENDIF
+   IF ( (plev == 3).AND.lact_mode) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE ipslerr
+!===
+SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!--------------------------------------------------------------------
+!! The "ipslerr_act" routine allows to know and modify
+!! the current "action mode" for the error messages,
+!! and reinitialize the error level values.
+!!
+!! SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_mode : new error action mode
+!!                .TRUE.  -> STOP     in case of fatal error
+!!                .FALSE. -> CONTINUE in case of fatal error
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_mode : current error action mode
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_mode
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode
+!---------------------------------------------------------------------
+  IF (PRESENT(old_mode)) THEN
+    old_mode = lact_mode
+  ENDIF
+  IF (PRESENT(new_mode)) THEN
+    lact_mode = new_mode
+  ENDIF
+  ilv_cur = 0
+  ilv_max = 0
+!-------------------------
+END SUBROUTINE ipslerr_act
+!===
+SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!--------------------------------------------------------------------
+!! The "ipslerr_inq" routine allows to know
+!! the current level of the error messages
+!! and the maximum level encountered since the
+!! last call to "ipslerr_act".
+!!
+!! SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) current_level : current error level
+!! (I) maximum_level : maximum error level
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level
+!---------------------------------------------------------------------
+  IF (PRESENT(current_level)) THEN
+    current_level = ilv_cur
+  ENDIF
+  IF (PRESENT(maximum_level)) THEN
+    maximum_level = ilv_max
+  ENDIF
+!-------------------------
+END SUBROUTINE ipslerr_inq
+!===
+SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!- INPUT
+!- plev   : Category of message to be reported to the user
+!-          1 = Note to the user
+!-          2 = Warning to the user
+!-          3 = Fatal error
+!- pcname : Name of subroutine which has called histerr
+!- pstr1   
+!- pstr2  : String containing the explanations to the user
+!- pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     WRITE(*,'("     ")')
+     WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(*,'(" --> ",A)') pstr1
+     WRITE(*,'(" --> ",A)') pstr2
+     WRITE(*,'(" --> ",A)') pstr3
+   ENDIF
+   IF (plev == 3) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE histerr
+!===
+SUBROUTINE ipsldbg (new_status,old_status)
+!!--------------------------------------------------------------------
+!! The "ipsldbg" routine
+!! allows to activate or deactivate the debug,
+!! and to know the current status of the debug.
+!!
+!! SUBROUTINE ipsldbg (new_status,old_status)
+!!
+!! Optional INPUT argument
+!!
+!! (L) new_status : new status of the debug
+!!
+!! Optional OUTPUT argument
+!!
+!! (L) old_status : current status of the debug
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
+!---------------------------------------------------------------------
+  IF (PRESENT(old_status)) THEN
+    old_status = ioipsl_debug
+  ENDIF
+  IF (PRESENT(new_status)) THEN
+    ioipsl_debug = new_status
+  ENDIF
+!---------------------
+END SUBROUTINE ipsldbg
+!===
+!-------------------
+END MODULE ioipsl_errioipsl
Index: LMDZ5/branches/testing/libf/misc/ioipsl_getincom.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/ioipsl_getincom.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ioipsl_getincom.F90	(revision 2298)
@@ -0,0 +1,1980 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_getincom
+!-
+!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+USE ioipsl_errioipsl, ONLY : ipslerr
+USE ioipsl_stringop, &
+ &   ONLY : nocomma,cmpblank,strlowercase
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+PUBLIC :: getin, getin_dump
+!-
+INTERFACE getin
+!!--------------------------------------------------------------------
+!! The "getin" routines get a variable.
+!! We first check if we find it in the database
+!! and if not we get it from the run.def file.
+!!
+!! SUBROUTINE getin (target,ret_val)
+!!
+!! INPUT
+!!
+!! (C) target : Name of the variable
+!!
+!! OUTPUT
+!!
+!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
+!!                     that will contain the (standard)
+!!                     integer/real/character/logical values
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
+ &                 getinis, getini1d, getini2d, &
+ &                 getincs, getinc1d, getinc2d, &
+ &                 getinls, getinl1d, getinl2d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "getin_dump" routine will dump the content of the database
+!! into a file which has the same format as the run.def file.
+!! The idea is that the user can see which parameters were used
+!! and re-use the file for another run.
+!!
+!!  SUBROUTINE getin_dump (fileprefix)
+!!
+!! OPTIONAL INPUT argument
+!!
+!! (C) fileprefix : allows the user to change the name of the file
+!!                  in which the data will be archived
+!!--------------------------------------------------------------------
+!-
+  INTEGER,PARAMETER :: max_files=100
+  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
+  INTEGER,SAVE      :: nbfiles
+!-
+  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
+  INTEGER,SAVE :: nb_lines,i_txtsize=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
+  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
+!-
+  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
+  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
+!-
+! The data base of parameters
+!-
+  INTEGER,PARAMETER :: memslabs=200
+  INTEGER,PARAMETER :: compress_lim=20
+!-
+  INTEGER,SAVE :: nb_keys=0
+  INTEGER,SAVE :: keymemsize=0
+!-
+! keystr definition
+! name of a key
+!-
+! keystatus definition
+! keystatus = 1 : Value comes from run.def
+! keystatus = 2 : Default value is used
+! keystatus = 3 : Some vector elements were taken from default
+!-
+! keytype definition
+! keytype = 1 : Integer
+! keytype = 2 : Real
+! keytype = 3 : Character
+! keytype = 4 : Logical
+!-
+  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
+!-
+! Allow compression for keys (only for integer and real)
+! keycompress < 0 : not compressed
+! keycompress > 0 : number of repeat of the value
+!-
+TYPE :: t_key
+  CHARACTER(LEN=l_n) :: keystr
+  INTEGER :: keystatus, keytype, keycompress, &
+ &           keyfromfile, keymemstart, keymemlen
+END TYPE t_key
+!-
+  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
+!-
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
+  INTEGER,SAVE :: i_memsize=0, i_mempos=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
+  INTEGER,SAVE :: r_memsize=0, r_mempos=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
+  INTEGER,SAVE :: c_memsize=0, c_mempos=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
+  INTEGER,SAVE :: l_memsize=0, l_mempos=0
+!-
+CONTAINS
+!-
+!=== INTEGER INTERFACE
+!-
+SUBROUTINE getinis (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: ret_val
+!-
+  INTEGER,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinis
+!===
+SUBROUTINE getini1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getini1d
+!===
+SUBROUTINE getini2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:,:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getini2d
+!-
+!=== REAL INTERFACE
+!-
+SUBROUTINE getinrs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL :: ret_val
+!-
+  REAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinrs
+!===
+SUBROUTINE getinr1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinr1d
+!===
+SUBROUTINE getinr2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:,:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinr2d
+!-
+!=== CHARACTER INTERFACE
+!-
+SUBROUTINE getincs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getincs
+!===
+SUBROUTINE getinc1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinc1d
+!===
+SUBROUTINE getinc2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinc2d
+!-
+!=== LOGICAL INTERFACE
+!-
+SUBROUTINE getinls (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL :: ret_val
+!-
+  LOGICAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinls
+!===
+SUBROUTINE getinl1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinl1d
+!===
+SUBROUTINE getinl2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:,:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinl2d
+!-
+!=== Generic file/database INTERFACE
+!-
+SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Subroutine that will extract from the file the values
+!- attributed to the keyword target
+!-
+!- (C) target    : target for which we will look in the file
+!- (I) status    : tells us from where we obtained the data
+!- (I) fileorig  : index of the file from which the key comes
+!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
+!- (R) r_val(:)  : REAL(nb_to_ret)      values
+!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
+!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,INTENT(OUT) :: status,fileorig
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
+  CHARACTER(LEN=n_d_fmt)  :: cnt
+  CHARACTER(LEN=80) :: str_READ,str_READ_lower
+  CHARACTER(LEN=9)  :: c_vtyp
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
+  LOGICAL :: def_beha,compressed
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: i_cmpval
+  REAL    :: r_cmpval
+  INTEGER :: ipos_tr,ipos_fl
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    nb_to_ret = SIZE(i_val)
+  CASE(k_r)
+    nb_to_ret = SIZE(r_val)
+  CASE(k_c)
+    nb_to_ret = SIZE(c_val)
+  CASE(k_l)
+    nb_to_ret = SIZE(l_val)
+  CASE DEFAULT
+    CALL ipslerr (3,'get_fil', &
+ &   'Internal error','Unknown type of data',' ')
+  END SELECT
+!-
+! Read the file(s)
+  CALL getin_read
+!-
+! Allocate and initialize the memory we need
+  ALLOCATE(found(nb_to_ret))
+  found(:) = .FALSE.
+!-
+! See what we find in the files read
+  DO it=1,nb_to_ret
+!---
+!-- First try the target as it is
+    CALL get_findkey (2,target,pos)
+!---
+!-- Another try
+!---
+    IF (pos < 0) THEN
+      WRITE(UNIT=cnt,FMT=c_i_fmt) it
+      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
+    ENDIF
+!---
+!-- We dont know from which file the target could come.
+!-- Thus by default we attribute it to the first file :
+    fileorig = 1
+!---
+    IF (pos > 0) THEN
+!-----
+      found(it) = .TRUE.
+      fileorig = fromfile(pos)
+!-----
+!---- DECODE
+!-----
+      str_READ = ADJUSTL(fichier(pos))
+      str_READ_lower = str_READ
+      CALL strlowercase (str_READ_lower)
+!-----
+      IF (    (TRIM(str_READ_lower) == 'def')     &
+ &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
+        def_beha = .TRUE.
+      ELSE
+        def_beha = .FALSE.
+        len_str = LEN_TRIM(str_READ)
+        io_err = 0
+        SELECT CASE (k_typ)
+        CASE(k_i)
+          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
+        CASE(k_r)
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=*,IOSTAT=io_err) r_val(it)
+        CASE(k_c)
+          c_val(it) = str_READ(1:len_str)
+        CASE(k_l)
+          ipos_tr = -1
+          ipos_fl = -1
+          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
+ &                      INDEX(str_READ_lower,'y'))
+          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
+ &                      INDEX(str_READ_lower,'n'))
+          IF (ipos_tr > 0) THEN
+            l_val(it) = .TRUE.
+          ELSE IF (ipos_fl > 0) THEN
+            l_val(it) = .FALSE.
+          ELSE
+            io_err = 100
+          ENDIF
+        END SELECT
+        IF (io_err /= 0) THEN
+          CALL ipslerr (3,'get_fil', &
+ &         'Target '//TRIM(target), &
+ &         'is not of '//TRIM(c_vtyp)//' type',' ')
+        ENDIF
+      ENDIF
+!-----
+      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!-------
+!------ Is this the value of a compressed field ?
+        compressed = (compline(pos) > 0)
+        IF (compressed) THEN
+          IF (compline(pos) /= nb_to_ret) THEN
+            CALL ipslerr (2,'get_fil', &
+ &           'For key '//TRIM(target)//' we have a compressed field', &
+ &           'which does not have the right size.', &
+ &           'We will try to fix that.')
+          ENDIF
+          IF      (k_typ == k_i) THEN
+            i_cmpval = i_val(it)
+          ELSE IF (k_typ == k_r) THEN
+            r_cmpval = r_val(it)
+          ENDIF
+        ENDIF
+      ENDIF
+    ELSE
+      found(it) = .FALSE.
+      def_beha = .FALSE.
+      compressed = .FALSE.
+    ENDIF
+  ENDDO
+!-
+  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!---
+!-- If this is a compressed field then we will uncompress it
+    IF (compressed) THEN
+      DO it=1,nb_to_ret
+        IF (.NOT.found(it)) THEN
+          IF      (k_typ == k_i) THEN
+            i_val(it) = i_cmpval
+          ELSE IF (k_typ == k_r) THEN
+          ENDIF
+          found(it) = .TRUE.
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+! Now we set the status for what we found
+  IF (def_beha) THEN
+    status = 2
+    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
+  ELSE
+    status_cnt = 0
+    DO it=1,nb_to_ret
+      IF (.NOT.found(it)) THEN
+        status_cnt = status_cnt+1
+        IF      (status_cnt <= max_msgs) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
+ &               ADVANCE='NO') TRIM(target)
+          IF (nb_to_ret > 1) THEN
+            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
+            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
+          ENDIF
+          SELECT CASE (k_typ)
+          CASE(k_i)
+            WRITE (UNIT=*,FMT=*) "=",i_val(it)
+          CASE(k_r)
+            WRITE (UNIT=*,FMT=*) "=",r_val(it)
+          CASE(k_c)
+            WRITE (UNIT=*,FMT=*) "=",c_val(it)
+          CASE(k_l)
+            WRITE (UNIT=*,FMT=*) "=",l_val(it)
+          END SELECT
+        ELSE IF (status_cnt == max_msgs+1) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
+        ENDIF
+      ENDIF
+    ENDDO
+!---
+    IF (status_cnt == 0) THEN
+      status = 1
+    ELSE IF (status_cnt == nb_to_ret) THEN
+      status = 2
+    ELSE
+      status = 3
+    ENDIF
+  ENDIF
+! Deallocate the memory
+  DEALLOCATE(found)
+!---------------------
+END SUBROUTINE get_fil
+!===
+SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Read the required variable in the database
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: pos,size_of_in
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,k_beg,k_end
+  CHARACTER(LEN=9) :: c_vtyp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keytype /= k_typ) THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Wrong data type for keyword '//TRIM(target), &
+ &   '(NOT '//TRIM(c_vtyp)//')',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keycompress > 0) THEN
+    IF (    (key_tab(pos)%keycompress /= size_of_in) &
+ &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong compression length','for keyword '//TRIM(target),' ')
+    ELSE
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
+      END SELECT
+    ENDIF
+  ELSE
+    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong array length','for keyword '//TRIM(target),' ')
+    ELSE
+      k_beg = key_tab(pos)%keymemstart
+      k_end = k_beg+key_tab(pos)%keymemlen-1
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(k_beg:k_end)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(k_beg:k_end)
+      CASE(k_c)
+        c_val(1:size_of_in) = c_mem(k_beg:k_end)
+      CASE(k_l)
+        l_val(1:size_of_in) = l_mem(k_beg:k_end)
+      END SELECT
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE get_rdb
+!===
+SUBROUTINE get_wdb &
+ &  (target,status,fileorig,size_of_in, &
+ &   i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Write data into the data base
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: status,fileorig,size_of_in
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ
+  CHARACTER(LEN=9) :: c_vtyp
+  INTEGER :: k_mempos,k_memsize,k_beg,k_end
+  LOGICAL :: l_cmp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_wdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+! First check if we have sufficiant space for the new key
+  IF (nb_keys+1 > keymemsize) THEN
+    CALL getin_allockeys ()
+  ENDIF
+!-
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    k_mempos = i_mempos; k_memsize = i_memsize;
+    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_r)
+    k_mempos = r_mempos; k_memsize = r_memsize;
+    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_c)
+    k_mempos = c_mempos; k_memsize = c_memsize;
+    l_cmp = .FALSE.
+  CASE(k_l)
+    k_mempos = l_mempos; k_memsize = l_memsize;
+    l_cmp = .FALSE.
+  END SELECT
+!-
+! Fill out the items of the data base
+  nb_keys = nb_keys+1
+  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
+  key_tab(nb_keys)%keystatus = status
+  key_tab(nb_keys)%keytype = k_typ
+  key_tab(nb_keys)%keyfromfile = fileorig
+  key_tab(nb_keys)%keymemstart = k_mempos+1
+  IF (l_cmp) THEN
+    key_tab(nb_keys)%keycompress = size_of_in
+    key_tab(nb_keys)%keymemlen = 1
+  ELSE
+    key_tab(nb_keys)%keycompress = -1
+    key_tab(nb_keys)%keymemlen = size_of_in
+  ENDIF
+!-
+! Before writing the actual size lets see if we have the space
+  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
+ &    > k_memsize) THEN
+    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
+  ENDIF
+!-
+  k_beg = key_tab(nb_keys)%keymemstart
+  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
+    i_mempos = k_end
+  CASE(k_r)
+    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
+    r_mempos = k_end
+  CASE(k_c)
+    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
+    c_mempos = k_end
+  CASE(k_l)
+    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
+    l_mempos = k_end
+  END SELECT
+!---------------------
+END SUBROUTINE get_wdb
+!-
+!===
+!-
+SUBROUTINE getin_read
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,SAVE :: allread=0
+  INTEGER,SAVE :: current
+!---------------------------------------------------------------------
+  IF (allread == 0) THEN
+!-- Allocate a first set of memory.
+    CALL getin_alloctxt ()
+    CALL getin_allockeys ()
+    CALL getin_allocmem (k_i,0)
+    CALL getin_allocmem (k_r,0)
+    CALL getin_allocmem (k_c,0)
+    CALL getin_allocmem (k_l,0)
+!-- Start with reading the files
+    nbfiles = 1
+    filelist(1) = 'run.def'
+    current = 1
+!--
+    DO WHILE (current <= nbfiles)
+      CALL getin_readdef (current)
+      current = current+1
+    ENDDO
+    allread = 1
+    CALL getin_checkcohe ()
+  ENDIF
+!------------------------
+END SUBROUTINE getin_read
+!-
+!===
+!-
+  SUBROUTINE getin_readdef(current)
+!---------------------------------------------------------------------
+!- This subroutine will read the files and only keep the
+!- the relevant information. The information is kept as it
+!- found in the file. The data will be analysed later.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: current
+!-
+  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: nb_lastkey
+!-
+  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  eof = 0
+  ptn = 1
+  nb_lastkey = 0
+!-
+  IF (check) THEN
+    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
+  ENDIF
+!-
+  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
+  IF (io_err /= 0) THEN
+    CALL ipslerr (2,'getin_readdef', &
+ &  'Could not open file '//TRIM(filelist(current)),' ',' ')
+    RETURN
+  ENDIF
+!-
+  DO WHILE (eof /= 1)
+!---
+    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
+    len_str = LEN_TRIM(READ_str)
+    ptn = INDEX(READ_str,'=')
+!---
+    IF (ptn > 0) THEN
+!---- Get the target
+      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
+!---- Make sure that a vector keyword has the right length
+      iund = INDEX(key_str,'__')
+      IF (iund > 0) THEN
+        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
+ &        LEN_TRIM(key_str)-iund-1
+        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
+ &           FMT=c_fmt,IOSTAT=io_err) it
+        IF ( (io_err == 0).AND.(it > 0) ) THEN
+          WRITE(UNIT=cnt,FMT=c_i_fmt) it
+          key_str = key_str(1:iund+1)//cnt
+        ELSE
+          CALL ipslerr (3,'getin_readdef', &
+ &         'A very strange key has just been found :', &
+ &         TRIM(key_str),' ')
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
+      CALL nocomma (NEW_str)
+      CALL cmpblank (NEW_str)
+      NEW_str  = TRIM(ADJUSTL(NEW_str))
+      IF (check) THEN
+        WRITE(*,*) &
+ &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
+      ENDIF
+!---- Decypher the content of NEW_str
+!-
+!---- This has to be a new key word, thus :
+      nb_lastkey = 0
+!----
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+!----
+    ELSE IF (len_str > 0) THEN
+!---- Prepare the key if we have an old one to which
+!---- we will add the line just read
+      IF (nb_lastkey > 0) THEN
+        iund =  INDEX(last_key,'__')
+        IF (iund > 0) THEN
+!-------- We only continue a keyword, thus it is easy
+          key_str = last_key(1:iund-1)
+        ELSE
+          IF (nb_lastkey /= 1) THEN
+            CALL ipslerr (3,'getin_readdef', &
+ &           'We can not have a scalar keyword', &
+ &           'and a vector content',' ')
+          ENDIF
+!-------- The last keyword needs to be transformed into a vector.
+          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
+          targetlist(nb_lines) = &
+ &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
+          key_str = last_key(1:LEN_TRIM(last_key))
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+    ELSE
+!---- If we have an empty line then the keyword finishes
+      nb_lastkey = 0
+      IF (check) THEN
+        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
+      ENDIF
+    ENDIF
+  ENDDO
+!-
+  CLOSE(UNIT=22)
+!-
+  IF (check) THEN
+    OPEN (UNIT=22,file='run.def.test')
+    DO i=1,nb_lines
+      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
+    ENDDO
+    CLOSE(UNIT=22)
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_readdef
+!-
+!===
+!-
+SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
+!---------------------------------------------------------------------
+!- This subroutine is going to decypher the line.
+!- It essentialy checks how many items are included and
+!- it they can be attached to a key.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: current,nb_lastkey
+  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
+!-
+! LOCAL
+!-
+  INTEGER :: len_str,blk,nbve,starpos
+  CHARACTER(LEN=100) :: tmp_str,new_key,mult
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+!---------------------------------------------------------------------
+  len_str = LEN_TRIM(NEW_str)
+  blk = INDEX(NEW_str(1:len_str),' ')
+  tmp_str = NEW_str(1:len_str)
+!-
+! If the key is a new file then we take it up. Else
+! we save the line and go on.
+!-
+  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
+    DO WHILE (blk > 0)
+      IF (nbfiles+1 > max_files) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'Too many files to include',' ',' ')
+      ENDIF
+!-----
+      nbfiles = nbfiles+1
+      filelist(nbfiles) = tmp_str(1:blk)
+!-----
+      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
+    ENDDO
+!---
+    IF (nbfiles+1 > max_files) THEN
+      CALL ipslerr (3,'getin_decrypt', &
+ &     'Too many files to include',' ',' ')
+    ENDIF
+!---
+    nbfiles =  nbfiles+1
+    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
+!---
+    last_key = 'INCLUDEDEF'
+    nb_lastkey = 1
+  ELSE
+!-
+!-- We are working on a new line of input
+!-
+    IF (nb_lines+1 > i_txtsize) THEN
+      CALL getin_alloctxt ()
+    ENDIF
+    nb_lines = nb_lines+1
+!-
+!-- First we solve the issue of conpressed information. Once
+!-- this is done all line can be handled in the same way.
+!-
+    starpos = INDEX(NEW_str(1:len_str),'*')
+    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
+ &                    .AND.(tmp_str(1:1) /= "'") ) THEN
+!-----
+      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We can not have a compressed field of values', &
+ &       'in a vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str))
+      ENDIF
+!-
+!---- Read the multiplied
+!-
+      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
+!---- Construct the new string and its parameters
+      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
+      len_str = LEN_TRIM(NEW_str)
+      blk = INDEX(NEW_str(1:len_str),' ')
+      IF (blk > 1) THEN
+        CALL ipslerr (2,'getin_decrypt', &
+ &       'This is a strange behavior','you could report',' ')
+      ENDIF
+      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
+      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
+!---
+    ELSE
+      compline(nb_lines) = -1
+    ENDIF
+!-
+!-- If there is no space wthin the line then the target is a scalar
+!-- or the element of a properly written vector.
+!-- (ie of the type TARGET__00001)
+!-
+    IF (    (blk <= 1) &
+ &      .OR.(tmp_str(1:1) == '"') &
+ &      .OR.(tmp_str(1:1) == "'") ) THEN
+!-
+      IF (nb_lastkey == 0) THEN
+!------ Save info of current keyword as a scalar
+!------ if it is not a continuation
+        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        nb_lastkey = 1
+      ELSE
+!------ We are continuing a vector so the keyword needs
+!------ to get the underscores
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
+        targetlist(nb_lines) = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        last_key = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        nb_lastkey = nb_lastkey+1
+      ENDIF
+!-----
+      fichier(nb_lines) = NEW_str(1:len_str)
+      fromfile(nb_lines) = current
+    ELSE
+!-
+!---- If there are blanks whithin the line then we are dealing
+!---- with a vector and we need to split it in many entries
+!---- with the TARGET__n notation.
+!----
+!---- Test if the targer is not already a vector target !
+!-
+      IF (INDEX(TRIM(key_str),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We have found a mixed vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str),' ')
+      ENDIF
+!-
+      nbve = nb_lastkey
+      nbve = nbve+1
+      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      DO WHILE (blk > 0)
+!-
+!------ Save the content of target__nbve
+!-
+        fichier(nb_lines) = tmp_str(1:blk)
+        new_key = &
+ &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+        fromfile(nb_lines) = current
+!-
+        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+        blk = INDEX(TRIM(tmp_str),' ')
+!-
+        IF (nb_lines+1 > i_txtsize) THEN
+          CALL getin_alloctxt ()
+        ENDIF
+        nb_lines = nb_lines+1
+        nbve = nbve+1
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      ENDDO
+!-
+!---- Save the content of the last target
+!-
+      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
+      new_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+      fromfile(nb_lines) = current
+!-
+      last_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      nb_lastkey = nbve
+!-
+    ENDIF
+!-
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_decrypt
+!-
+!===
+!-
+SUBROUTINE getin_checkcohe ()
+!---------------------------------------------------------------------
+!- This subroutine checks for redundancies.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: line,n_k,k
+!---------------------------------------------------------------------
+  DO line=1,nb_lines-1
+!-
+    n_k = 0
+    DO k=line+1,nb_lines
+      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
+        n_k = k
+        EXIT
+      ENDIF
+    ENDDO
+!---
+!-- IF we have found it we have a problem to solve.
+!---
+    IF (n_k > 0) THEN
+      WRITE(*,*) 'COUNT : ',n_k
+      WRITE(*,*) &
+ &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
+      WRITE(*,*) &
+ &  'getin_checkcohe : The following values were encoutered :'
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
+      WRITE(*,*) &
+ &  'getin_checkcohe : We will keep only the last value'
+      targetlist(line) = ' '
+    ENDIF
+  ENDDO
+!-----------------------------
+END SUBROUTINE getin_checkcohe
+!-
+!===
+!-
+SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: unit,eof,nb_lastkey
+  CHARACTER(LEN=100) :: dummy
+  CHARACTER(LEN=100) :: out_string
+  CHARACTER(LEN=1) :: first
+!---------------------------------------------------------------------
+  first="#"
+  eof = 0
+  out_string = "    "
+!-
+  DO WHILE (first == "#")
+    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
+    dummy = TRIM(ADJUSTL(dummy))
+    first=dummy(1:1)
+    IF (first == "#") THEN
+      nb_lastkey = 0
+    ENDIF
+  ENDDO
+  out_string=dummy
+!-
+  RETURN
+!-
+9998 CONTINUE
+  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
+!-
+7778 CONTINUE
+  eof = 1
+!----------------------------
+END SUBROUTINE getin_skipafew
+!-
+!===
+!-
+SUBROUTINE getin_allockeys ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  IF (keymemsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) memslabs
+    ALLOCATE(key_tab(memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    nb_keys = 0
+    keymemsize = memslabs
+    key_tab(:)%keycompress = -1
+!---
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize
+    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate tmp_key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
+    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
+    DEALLOCATE(key_tab)
+    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    key_tab(:)%keycompress = -1
+    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
+    DEALLOCATE(tmp_key_tab)
+    keymemsize = keymemsize+memslabs
+  ENDIF
+!-----------------------------
+END SUBROUTINE getin_allockeys
+!-
+!===
+!-
+SUBROUTINE getin_allocmem (type,len_wanted)
+!---------------------------------------------------------------------
+!- Allocate the memory of the data base for all 4 types of memory
+!- INTEGER / REAL / CHARACTER / LOGICAL
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: type,len_wanted
+!-
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+  REAL,ALLOCATABLE :: tmp_real(:)
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
+  LOGICAL,ALLOCATABLE :: tmp_logic(:)
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  SELECT CASE (type)
+  CASE(k_i)
+    IF (i_memsize == 0) THEN
+      ALLOCATE(i_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_memsize=memslabs
+    ELSE
+      ALLOCATE(tmp_int(i_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_int', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
+      DEALLOCATE(i_mem)
+      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
+      i_memsize = i_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_int)
+    ENDIF
+  CASE(k_r)
+    IF (r_memsize == 0) THEN
+      ALLOCATE(r_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_memsize =  memslabs
+    ELSE
+      ALLOCATE(tmp_real(r_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_real', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
+      DEALLOCATE(r_mem)
+      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
+      r_memsize = r_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_real)
+    ENDIF
+  CASE(k_c)
+    IF (c_memsize == 0) THEN
+      ALLOCATE(c_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_char(c_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_char', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
+      DEALLOCATE(c_mem)
+      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
+      c_memsize = c_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_char)
+    ENDIF
+  CASE(k_l)
+    IF (l_memsize == 0) THEN
+      ALLOCATE(l_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_logic(l_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_logic', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
+      DEALLOCATE(l_mem)
+      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
+      l_memsize = l_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_logic)
+    ENDIF
+  CASE DEFAULT
+    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
+  END SELECT
+!----------------------------
+END SUBROUTINE getin_allocmem
+!-
+!===
+!-
+SUBROUTINE getin_alloctxt ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
+  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
+!---------------------------------------------------------------------
+  IF (i_txtsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
+    ALLOCATE(fichier(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(targetlist(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(fromfile(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(compline(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    nb_lines = 0
+    i_txtsize = i_txtslab
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
+    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
+    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_fic', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
+    DEALLOCATE(fichier)
+    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
+    DEALLOCATE(tmp_fic)
+!---
+    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_tgl', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
+    DEALLOCATE(targetlist)
+    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
+    DEALLOCATE(tmp_tgl)
+!---
+    ALLOCATE(tmp_int(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_int', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
+    DEALLOCATE(fromfile)
+    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
+!---
+    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
+    DEALLOCATE(compline)
+    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
+    DEALLOCATE(tmp_int)
+!---
+    i_txtsize = i_txtsize+i_txtslab
+  ENDIF
+!----------------------------
+END SUBROUTINE getin_alloctxt
+!-
+!===
+!-
+SUBROUTINE getin_dump (fileprefix)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(*),OPTIONAL :: fileprefix
+!-
+  CHARACTER(LEN=80) :: usedfileprefix
+  INTEGER :: ikey,if,iff,iv
+  CHARACTER(LEN=20) :: c_tmp
+  CHARACTER(LEN=100) :: tmp_str,used_filename
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  IF (PRESENT(fileprefix)) THEN
+    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
+  ELSE
+    usedfileprefix = "used"
+  ENDIF
+!-
+  DO if=1,nbfiles
+!---
+    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
+    IF (check) THEN
+      WRITE(*,*) &
+ &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
+      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
+    ENDIF
+    OPEN (UNIT=22,FILE=used_filename)
+!---
+!-- If this is the first file we need to add the list
+!-- of file which belong to it
+    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
+      WRITE(22,*) '# '
+      WRITE(22,*) '# This file is linked to the following files :'
+      WRITE(22,*) '# '
+      DO iff=2,nbfiles
+        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
+      ENDDO
+      WRITE(22,*) '# '
+    ENDIF
+!---
+    DO ikey=1,nb_keys
+!-----
+!---- Is this key from this file ?
+      IF (key_tab(ikey)%keyfromfile == if) THEN
+!-------
+!------ Write some comments
+        WRITE(22,*) '#'
+        SELECT CASE (key_tab(ikey)%keystatus)
+        CASE(1)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes from the run.def.'
+        CASE(2)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
+        CASE(3)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr), &
+ &          ' are a mix of run.def and defaults.'
+        CASE DEFAULT
+          WRITE(22,*) '# Dont know from where the value of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes.'
+        END SELECT
+        WRITE(22,*) '#'
+!-------
+!------ Write the values
+        SELECT CASE (key_tab(ikey)%keytype)
+        CASE(k_i)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+ &              ' * ',i_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_r)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_c)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            tmp_str = c_mem(key_tab(ikey)%keymemstart)
+            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',TRIM(tmp_str)
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',TRIM(tmp_str)
+            ENDDO
+          ENDIF
+        CASE(k_l)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
+            ELSE
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
+              ELSE
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
+              ENDIF
+            ENDDO
+          ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'getin_dump', &
+ &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
+ &         ' ',' ')
+        END SELECT
+      ENDIF
+    ENDDO
+!-
+    CLOSE(UNIT=22)
+!-
+  ENDDO
+!------------------------
+END SUBROUTINE getin_dump
+!===
+SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
+!---------------------------------------------------------------------
+!- Returns the type of the argument (mutually exclusive)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(OUT) :: k_typ
+  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
+  REAL,DIMENSION(:),OPTIONAL             :: r_v
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
+!---------------------------------------------------------------------
+  k_typ = 0
+  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
+ &    /= 1) THEN
+    CALL ipslerr (3,'get_qtyp', &
+ &   'Invalid number of optional arguments','(/= 1)',' ')
+  ENDIF
+!-
+  IF     (PRESENT(i_v)) THEN
+    k_typ = k_i
+    c_vtyp = 'INTEGER'
+  ELSEIF (PRESENT(r_v)) THEN
+    k_typ = k_r
+    c_vtyp = 'REAL'
+  ELSEIF (PRESENT(c_v)) THEN
+    k_typ = k_c
+    c_vtyp = 'CHARACTER'
+  ELSEIF (PRESENT(l_v)) THEN
+    k_typ = k_l
+    c_vtyp = 'LOGICAL'
+  ENDIF
+!----------------------
+END SUBROUTINE get_qtyp
+!===
+SUBROUTINE get_findkey (i_tab,c_key,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a key in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
+!-            2 -> search in targetlist(1:nb_lines)
+!-   c_key  : Name of the key we are looking for
+!- OUTPUT
+!-   pos    : -1 if key not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in) :: i_tab
+  CHARACTER(LEN=*),INTENT(in) :: c_key
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: ikey_max,ikey
+  CHARACTER(LEN=l_n) :: c_q_key
+!---------------------------------------------------------------------
+  pos = -1
+  IF     (i_tab == 1) THEN
+    ikey_max = nb_keys
+  ELSEIF (i_tab == 2) THEN
+    ikey_max = nb_lines
+  ELSE
+    ikey_max = 0
+  ENDIF
+  IF ( ikey_max > 0 ) THEN
+    DO ikey=1,ikey_max
+      IF (i_tab == 1) THEN
+        c_q_key = key_tab(ikey)%keystr
+      ELSE
+        c_q_key = targetlist(ikey)
+      ENDIF
+      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
+        pos = ikey
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-------------------------
+END SUBROUTINE get_findkey
+!===
+!------------------
+END MODULE ioipsl_getincom
Index: LMDZ5/branches/testing/libf/misc/ioipsl_stringop.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/ioipsl_stringop.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ioipsl_stringop.F90	(revision 2298)
@@ -0,0 +1,243 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_stringop
+!-
+!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+!-
+  INTEGER,DIMENSION(30) :: &
+ & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
+ & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
+!-
+!---------------------------------------------------------------------
+CONTAINS
+!=
+SUBROUTINE cmpblank (str)
+!---------------------------------------------------------------------
+!- Compact blanks
+!---------------------------------------------------------------------
+  CHARACTER(LEN=*),INTENT(inout) :: str
+!-
+  INTEGER :: lcc,ipb
+!---------------------------------------------------------------------
+  lcc = LEN_TRIM(str)
+  ipb = 1
+  DO
+    IF (ipb >= lcc)   EXIT
+    IF (str(ipb:ipb+1) == '  ') THEN
+      str(ipb+1:) = str(ipb+2:lcc)
+      lcc = lcc-1
+    ELSE
+      ipb = ipb+1
+    ENDIF
+  ENDDO
+!----------------------
+END SUBROUTINE cmpblank
+!===
+INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds number of occurences of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!-
+  INTEGER :: ipos,indx
+!---------------------------------------------------------------------
+  cntpos = 0
+  ipos   = 1
+  DO
+    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
+    IF (indx > 0) THEN
+      cntpos = cntpos+1
+      ipos   = ipos+indx+l_r-1
+    ELSE
+      EXIT
+    ENDIF
+  ENDDO
+!------------------
+END FUNCTION cntpos
+!===
+INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds position of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!---------------------------------------------------------------------
+  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
+  IF (findpos == 0)  findpos=-1
+!-------------------
+END FUNCTION findpos
+!===
+SUBROUTINE find_str (str_tab,str,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a string in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   str_tab  : Table  of strings
+!-   str      : Target we are looking for
+!- OUTPUT
+!-   pos      : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
+  CHARACTER(LEN=*),INTENT(in) :: str
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: nb_str,i
+!---------------------------------------------------------------------
+  pos = -1
+  nb_str=SIZE(str_tab)
+  IF ( nb_str > 0 ) THEN
+    DO i=1,nb_str
+      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
+        pos = i
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!----------------------
+END SUBROUTINE find_str
+!===
+SUBROUTINE nocomma (str)
+!---------------------------------------------------------------------
+!- Replace commas with blanks
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    IF (str(i:i) == ',')   str(i:i) = ' '
+  ENDDO
+!---------------------
+END SUBROUTINE nocomma
+!===
+SUBROUTINE strlowercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into lowercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
+  ENDDO
+!--------------------------
+END SUBROUTINE strlowercase
+!===
+SUBROUTINE struppercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into uppercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
+  ENDDO
+!--------------------------
+END SUBROUTINE struppercase
+!===
+SUBROUTINE gensig (str,sig)
+!---------------------------------------------------------------------
+!- Generate a signature from the first 30 characters of the string
+!- This signature is not unique and thus when one looks for the
+!- one needs to also verify the string.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+  INTEGER          :: sig
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  sig = 0
+  DO i=1,MIN(LEN_TRIM(str),30)
+    sig = sig + prime(i)*IACHAR(str(i:i))
+  ENDDO
+!--------------------
+END SUBROUTINE gensig
+!===
+SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
+!---------------------------------------------------------------------
+!- Find the string signature in a list of signatures
+!---------------------------------------------------------------------
+!- INPUT
+!-   nb_sig      : length of table of signatures
+!-   str_tab     : Table of strings
+!-   str         : Target string we are looking for
+!-   sig_tab     : Table of signatures
+!-   sig         : Target signature we are looking for
+!- OUTPUT
+!-   pos         : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb_sig
+  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
+  CHARACTER(LEN=*) :: str
+  INTEGER,DIMENSION(nb_sig) :: sig_tab
+  INTEGER :: sig
+!-
+  INTEGER :: pos
+  INTEGER,DIMENSION(nb_sig) :: loczeros
+!-
+  INTEGER :: il,len
+  INTEGER,DIMENSION(1) :: minpos
+!---------------------------------------------------------------------
+  pos = -1
+  il = LEN_TRIM(str)
+!-
+  IF ( nb_sig > 0 ) THEN
+    loczeros = ABS(sig_tab(1:nb_sig)-sig)
+    IF ( COUNT(loczeros < 1) == 1 ) THEN
+      minpos = MINLOC(loczeros)
+      len = LEN_TRIM(str_tab(minpos(1)))
+      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+          .AND.(len == il) ) THEN
+        pos = minpos(1)
+      ENDIF
+    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
+      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
+        minpos = MINLOC(loczeros)
+        len = LEN_TRIM(str_tab(minpos(1)))
+        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+            .AND.(len == il) ) THEN
+          pos = minpos(1)
+        ELSE
+          loczeros(minpos(1)) = 99999
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-----------------------
+ END SUBROUTINE find_sig
+!===
+!------------------
+END MODULE ioipsl_stringop
Index: LMDZ5/branches/testing/libf/misc/ismax.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/ismax.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ismax.F	(revision 2298)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+      function ismax(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      INTEGER n,i,incx,ismax,ix
+      real sx((n-1)*incx+1),sxmax
+c
+      ix=1
+      ismax=1
+      sxmax=sx(1)
+      do 10 i=1,n-1
+       ix=ix+incx
+       if(sx(ix).gt.sxmax) then
+         sxmax=sx(ix)
+         ismax=i+1
+       endif
+10    continue
+c
+      return
+      end
+
Index: LMDZ5/branches/testing/libf/misc/ismin.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/ismin.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ismin.F	(revision 2298)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+      FUNCTION ismin(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,i,incx,ismin,ix
+      real sx((n-1)*incx+1),sxmin
+c
+      ix=1
+      ismin=1
+      sxmin=sx(1)
+      DO i=1,n-1
+         ix=ix+incx
+         if(sx(ix).lt.sxmin) then
+             sxmin=sx(ix)
+             ismin=i+1
+         endif
+      ENDDO
+c
+      return
+      end
+C
Index: LMDZ5/branches/testing/libf/misc/j4save.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/j4save.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/j4save.F	(revision 2298)
@@ -0,0 +1,67 @@
+*DECK J4SAVE
+      FUNCTION J4SAVE (IWHICH, IVALUE, ISET)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  J4SAVE
+C***SUBSIDIARY
+C***PURPOSE  Save or recall global variables needed by error
+C            handling routines.
+C***LIBRARY   SLATEC (XERROR)
+C***TYPE      INTEGER (J4SAVE-I)
+C***KEYWORDS  ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        J4SAVE saves and recalls several global variables needed
+C        by the library error handling routines.
+C
+C     Description of Parameters
+C      --Input--
+C        IWHICH - Index of item desired.
+C                = 1 Refers to current error number.
+C                = 2 Refers to current error control flag.
+C                = 3 Refers to current unit number to which error
+C                    messages are to be sent.  (0 means use standard.)
+C                = 4 Refers to the maximum number of times any
+C                     message is to be printed (as set by XERMAX).
+C                = 5 Refers to the total number of units to which
+C                     each error message is to be written.
+C                = 6 Refers to the 2nd unit for error messages
+C                = 7 Refers to the 3rd unit for error messages
+C                = 8 Refers to the 4th unit for error messages
+C                = 9 Refers to the 5th unit for error messages
+C        IVALUE - The value to be set for the IWHICH-th parameter,
+C                 if ISET is .TRUE. .
+C        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
+C                 given the value, IVALUE.  If ISET=.FALSE., the
+C                 IWHICH-th parameter will be unchanged, and IVALUE
+C                 is a dummy parameter.
+C      --Output--
+C        The (old) value of the IWHICH-th parameter will be returned
+C        in the function value, J4SAVE.
+C
+C***SEE ALSO  XERMSG
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900205  Minor modifications to prologue.  (WRB)
+C   900402  Added TYPE section.  (WRB)
+C   910411  Added KEYWORDS section.  (WRB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  J4SAVE
+      LOGICAL ISET
+      INTEGER IPARAM(9)
+      SAVE IPARAM
+      DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
+      DATA IPARAM(5)/1/
+      DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
+      INTEGER J4SAVE,IWHICH,IVALUE
+C***FIRST EXECUTABLE STATEMENT  J4SAVE
+      J4SAVE = IPARAM(IWHICH)
+      IF (ISET) IPARAM(IWHICH) = IVALUE
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/juldate.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/juldate.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/juldate.F	(revision 2298)
@@ -0,0 +1,39 @@
+!
+! $Id$
+!
+	subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
+c	Sous-routine de changement de date:
+c	gregorien>>>date julienne
+c	En entree:an,mois,jour,heure,min.,sec.
+c	En sortie:tjd
+        IMPLICIT NONE
+        INTEGER,INTENT(IN) :: ian,imoi,ijou,oh,om,os
+        REAL,INTENT(OUT) :: tjd,tjdsec
+        
+        REAL frac,year,rmon,cf,a,b
+        INTEGER ojou
+        
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dble(ijou)+frac
+	    year=dble(ian)
+	    rmon=dble(imoi)
+	if (imoi .le. 2) then
+	    year=year-1.
+	    rmon=rmon+12.
+	endif
+	cf=year+(rmon/100.)+(ojou/10000.)
+	if (cf .ge. 1582.1015) then
+	    a=int(year/100)
+	    b=2-a+int(a/4)
+	else
+	    b=0
+	endif
+	tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou)
+     +   +1720994.5+b
+        tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
+        tjd=int(tjd)+int(tjdsec)
+	tjdsec=tjdsec-int(tjdsec)
+	return
+	end
+
+
Index: LMDZ5/branches/testing/libf/misc/minmax.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/minmax.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/minmax.F	(revision 2298)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+       SUBROUTINE minmax(imax, xi, zmin, zmax )
+c
+c      P. Le Van
+
+       INTEGER imax
+       REAL    xi(imax)
+       REAL    zmin,zmax
+       INTEGER i
+
+       zmin = xi(1)
+       zmax = xi(1)
+
+       DO i = 2, imax
+         zmin = MIN( zmin,xi(i) )
+         zmax = MAX( zmax,xi(i) )
+       ENDDO
+
+       RETURN
+       END
+
Index: LMDZ5/branches/testing/libf/misc/minmax2.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/minmax2.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/minmax2.F	(revision 2298)
@@ -0,0 +1,20 @@
+!
+! $Header$
+!
+       SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax )
+c
+       INTEGER lmax,jmax,imax
+       REAL xi(imax*jmax*lmax) 
+       REAL zmin,zmax
+       INTEGER i
+    
+       zmin = xi(1)
+       zmax = xi(1)
+
+       DO i = 2, imax*jmax*lmax
+         zmin = MIN( zmin,xi(i) )
+         zmax = MAX( zmax,xi(i) )
+       ENDDO
+
+       RETURN
+       END
Index: LMDZ5/branches/testing/libf/misc/misc_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/misc_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/misc_mod.F90	(revision 2298)
@@ -0,0 +1,6 @@
+module misc_mod
+  integer,save :: itaumax
+  logical,save :: adjust
+  integer,save :: ItCount
+  logical,save :: debug
+end module misc_mod 
Index: LMDZ5/branches/testing/libf/misc/netcdf95.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/netcdf95.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/netcdf95.F90	(revision 2298)
@@ -0,0 +1,17 @@
+! $Id$
+module netcdf95
+
+  ! Author: Lionel GUEZ
+  ! See:
+  ! http://www.lmd.jussieu.fr/~lglmd/NetCDF95
+
+  use nf95_def_var_m
+  use nf95_put_var_m
+  use nf95_get_var_m
+  use nf95_gw_var_m
+  use nf95_put_att_m
+  use nf95_get_att_m
+  use simple
+  use handle_err_m
+
+end module netcdf95
Index: LMDZ5/branches/testing/libf/misc/new_unit_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/new_unit_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/new_unit_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/nf95_def_var_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_def_var_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_def_var_m.F90	(revision 2298)
@@ -0,0 +1,102 @@
+! $Id$
+module nf95_def_var_m
+
+  ! The generic procedure name "nf90_def_var" applies to
+  ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name
+  ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional
+  ! optional argument.
+  ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim".
+
+  implicit none
+
+  interface nf95_def_var
+    module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims
+  end interface
+
+  private
+  public nf95_def_var, nf95_def_var_scalar
+
+contains
+
+  subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_scalar
+
+  !***********************
+
+  subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_oneDim
+
+  !***********************
+
+  subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer, dimension(:), intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_ManyDims
+
+end module nf95_def_var_m
Index: LMDZ5/branches/testing/libf/misc/nf95_get_att_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_get_att_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_get_att_m.F90	(revision 2298)
@@ -0,0 +1,105 @@
+! $Id$
+module nf95_get_att_m
+
+  use handle_err_m, only: handle_err
+  use netcdf, only: nf90_get_att, nf90_noerr
+  use simple, only: nf95_inquire_attribute
+
+  implicit none
+
+  interface nf95_get_att
+     module procedure nf95_get_att_text, nf95_get_att_one_FourByteInt
+
+     ! The difference between the specific procedures is the type of
+     ! argument "values".
+  end interface
+
+  private
+  public nf95_get_att
+
+contains
+
+  subroutine nf95_get_att_text(ncid, varid, name, values, ncerr)
+
+    integer,                          intent( in) :: ncid, varid
+    character(len = *),               intent( in) :: name
+    character(len = *),               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the length of "values" is large enough:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (len(values) < att_len) then
+          print *, "nf95_get_att_text"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'length of "values" is not large enough'
+          print *, "len(values) = ", len(values)
+          print *, "number of characters in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    values = "" ! useless in NetCDF version 3.6.2 or better
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_text " // trim(name), ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+    if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then
+       ! Remove null terminator, if any:
+       if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " "
+    end if
+
+  end subroutine nf95_get_att_text
+
+  !***********************
+
+  subroutine nf95_get_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    integer,                                    intent( in) :: ncid, varid
+    character(len = *),                         intent( in) :: name
+    integer ,               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the attribute contains a single value:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (att_len /= 1) then
+          print *, "nf95_get_att_one_FourByteInt"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'the attribute does not contain a single value'
+          print *, "number of values in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_one_FourByteInt " // trim(name), &
+            ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_get_att_one_FourByteInt
+
+end module nf95_get_att_m
Index: LMDZ5/branches/testing/libf/misc/nf95_get_var_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_get_var_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_get_var_m.F90	(revision 2298)
@@ -0,0 +1,391 @@
+module nf95_get_var_m
+
+  use netcdf, only: nf90_get_var
+  use handle_err_m, only: handle_err
+
+  implicit none
+
+  interface nf95_get_var
+     module procedure nf95_get_var_FourByteReal, nf95_get_var_FourByteInt, &
+          nf95_get_var_1D_FourByteReal, nf95_get_var_1D_FourByteInt, &
+          nf95_get_var_2D_FourByteReal, &
+          nf95_get_var_3D_FourByteInt, &
+          nf95_get_var_3D_FourByteReal, &
+          nf95_get_var_4D_FourByteReal, &
+          nf95_get_var_5D_FourByteReal
+  end interface
+
+  private
+  public nf95_get_var
+
+contains
+
+  subroutine nf95_get_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    real, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    integer, intent(out):: values(:, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    real, intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_EightByteReal
+
+end module nf95_get_var_m
Index: LMDZ5/branches/testing/libf/misc/nf95_gw_var_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_gw_var_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_gw_var_m.F90	(revision 2298)
@@ -0,0 +1,336 @@
+! $Id$
+module nf95_gw_var_m
+
+  use nf95_get_var_m, only: NF95_GET_VAR
+  use simple, only: nf95_inquire_variable, nf95_inquire_dimension
+
+  implicit none
+
+  interface nf95_gw_var
+     ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable".
+     ! These procedures read a whole NetCDF variable (coordinate or
+     ! primary) into an array.
+     ! The difference between the procedures is the rank and type of
+     ! argument "values".
+     ! The procedures do not check the type of the NetCDF variable.
+
+     ! Not including double precision procedures in the generic
+     ! interface because we use a compilation option that changes default
+     ! real precision.
+     module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, &
+          nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_real_5d, &
+          nf95_gw_var_int_1d, nf95_gw_var_int_3d
+  end interface
+
+  private
+  public nf95_gw_var
+
+contains
+
+  subroutine nf95_gw_var_real_1d(ncid, varid, values)
+
+    ! Real type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_real_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_2d(ncid, varid, values)
+
+    ! Real type, the array has rank 2.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 2) then
+       print *, "nf95_gw_var_real_2d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 2"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2))
+    if (nclen1 /= 0 .and. nclen2 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_2d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_3d(ncid, varid, values)
+
+    ! Real type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_real_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_3d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_4d(ncid, varid, values)
+
+    ! Real type, the array has rank 4.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(4), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 4) then
+       print *, "nf95_gw_var_real_4d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 4"
+       stop 1
+    end if
+
+    do i = 1, 4
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_4d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_5d(ncid, varid, values)
+
+    ! Real type, the array has rank 5.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(5), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 5) then
+       print *, "nf95_gw_var_real_5d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 5"
+       stop 1
+    end if
+
+    do i = 1, 5
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_5d
+
+  !************************************
+
+!!$  subroutine nf95_gw_var_dble_1d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 1.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 1) then
+!!$       print *, "nf95_gw_var_dble_1d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+!!$        stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen))
+!!$    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_1d
+!!$
+!!$  !************************************
+!!$
+!!$  subroutine nf95_gw_var_dble_3d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 3.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:, :, :)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen1, nclen2, nclen3
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 3) then
+!!$       print *, "nf95_gw_var_dble_3d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+!!$       stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+!!$    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+!!$    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen1, nclen2, nclen3))
+!!$    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_3d
+!!$
+  !************************************
+
+  subroutine nf95_gw_var_int_1d(ncid, varid, values)
+
+    ! Integer type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_int_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_int_3d(ncid, varid, values)
+
+    ! Integer type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_int_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_3d
+
+end module nf95_gw_var_m
Index: LMDZ5/branches/testing/libf/misc/nf95_put_att_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_put_att_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_put_att_m.F90	(revision 2298)
@@ -0,0 +1,67 @@
+! $Id$
+module nf95_put_att_m
+
+  implicit none
+
+  interface nf95_put_att
+     module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt
+  end interface
+
+  private
+  public nf95_put_att
+
+contains
+
+  subroutine nf95_put_att_text(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    character(len = *), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_put_att_text
+
+  !************************************
+
+  subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+    use typesizes, only: FourByteInt
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    integer(kind = FourByteInt), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_att_one_FourByteInt
+
+end module nf95_put_att_m
Index: LMDZ5/branches/testing/libf/misc/nf95_put_var_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nf95_put_var_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nf95_put_var_m.F90	(revision 2298)
@@ -0,0 +1,335 @@
+! $Id$
+module nf95_put_var_m
+
+  implicit none
+
+  interface nf95_put_var
+     module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, &
+          nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, &
+          nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, &
+          nf95_put_var_4D_FourByteReal
+  end interface
+
+  private
+  public nf95_put_var
+
+contains
+
+  subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    real, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(in):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_EightByteReal
+
+end module nf95_put_var_m
Index: LMDZ5/branches/testing/libf/misc/nrtype.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/nrtype.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/nrtype.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/pchdf.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/pchdf.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pchdf.F	(revision 2298)
@@ -0,0 +1,106 @@
+*DECK PCHDF
+      REAL FUNCTION PCHDF (K, X, S, IERR)
+C***BEGIN PROLOGUE  PCHDF
+C***SUBSIDIARY
+C***PURPOSE  Computes divided differences for PCHCE and PCHSP
+C***LIBRARY   SLATEC (PCHIP)
+C***TYPE      SINGLE PRECISION (PCHDF-S, DPCHDF-D)
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C***DESCRIPTION
+C
+C          PCHDF:   PCHIP Finite Difference Formula
+C
+C     Uses a divided difference formulation to compute a K-point approx-
+C     imation to the derivative at X(K) based on the data in X and S.
+C
+C     Called by  PCHCE  and  PCHSP  to compute 3- and 4-point boundary
+C     derivative approximations.
+C
+C ----------------------------------------------------------------------
+C
+C     On input:
+C        K      is the order of the desired derivative approximation.
+C               K must be at least 3 (error return if not).
+C        X      contains the K values of the independent variable.
+C               X need not be ordered, but the values **MUST** be
+C               distinct.  (Not checked here.)
+C        S      contains the associated slope values:
+C                  S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
+C               (Note that S need only be of length K-1.)
+C
+C     On return:
+C        S      will be destroyed.
+C        IERR   will be set to -1 if K.LT.2 .
+C        PCHDF  will be set to the desired derivative approximation if
+C               IERR=0 or to zero if IERR=-1.
+C
+C ----------------------------------------------------------------------
+C
+C***SEE ALSO  PCHCE, PCHSP
+C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+C                 Verlag, New York, 1978, pp. 10-16.
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   820503  DATE WRITTEN
+C   820805  Converted to SLATEC library version.
+C   870813  Minor cosmetic changes.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890411  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   900328  Added TYPE section.  (WRB)
+C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
+C   920429  Revised format and order of references.  (WRB,FNF)
+C   930503  Improved purpose.  (FNF)
+C***END PROLOGUE  PCHDF
+C
+C**End
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  K, IERR
+      REAL  X(K), S(K)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I, J
+      REAL  VALUE, ZERO
+      SAVE ZERO
+      DATA  ZERO /0./
+C
+C  CHECK FOR LEGAL VALUE OF K.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHDF
+      IF (K .LT. 3)  GO TO 5001
+C
+C  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
+C
+      DO 10  J = 2, K-1
+         DO 9  I = 1, K-J
+            S(I) = (S(I+1)-S(I))/(X(I+J)-X(I))
+    9    CONTINUE
+   10 CONTINUE
+C
+C  EVALUATE DERIVATIVE AT X(K).
+C
+      VALUE = S(1)
+      DO 20  I = 2, K-1
+         VALUE = S(I) + VALUE*(X(K)-X(I))
+   20 CONTINUE
+C
+C  NORMAL RETURN.
+C
+      IERR = 0
+      PCHDF = VALUE
+      RETURN
+C
+C  ERROR RETURN.
+C
+ 5001 CONTINUE
+C     K.LT.3 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1)
+      PCHDF = ZERO
+      RETURN
+C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------
+      END
Index: LMDZ5/branches/testing/libf/misc/pchfe.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/pchfe.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pchfe.F	(revision 2298)
@@ -0,0 +1,308 @@
+*DECK PCHFE
+      SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+C***BEGIN PROLOGUE  PCHFE
+C***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
+C            points.  May be used by itself for Hermite interpolation,
+C            or as an evaluator for PCHIM or PCHIC.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E3
+C***TYPE      SINGLE PRECISION (PCHFE-S, DPCHFE-D)
+C***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
+C             PIECEWISE CUBIC EVALUATION
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          PCHFE:  Piecewise Cubic Hermite Function Evaluator
+C
+C     Evaluates the cubic Hermite function defined by  N, X, F, D  at
+C     the points  XE(J), J=1(1)NE.
+C
+C     To provide compatibility with PCHIM and PCHIC, includes an
+C     increment between successive values of the F- and D-arrays.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        PARAMETER  (INCFD = ...)
+C        INTEGER  N, NE, IERR
+C        REAL  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
+C        LOGICAL  SKIP
+C
+C        CALL  PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+C
+C   Parameters:
+C
+C     N -- (input) number of data points.  (Error return if N.LT.2 .)
+C
+C     X -- (input) real array of independent variable values.  The
+C           elements of X must be strictly increasing:
+C                X(I-1) .LT. X(I),  I = 2(1)N.
+C           (Error return if not.)
+C
+C     F -- (input) real array of function values.  F(1+(I-1)*INCFD) is
+C           the value corresponding to X(I).
+C
+C     D -- (input) real array of derivative values.  D(1+(I-1)*INCFD) is
+C           the value corresponding to X(I).
+C
+C     INCFD -- (input) increment between successive values in F and D.
+C           (Error return if  INCFD.LT.1 .)
+C
+C     SKIP -- (input/output) logical variable which should be set to
+C           .TRUE. if the user wishes to skip checks for validity of
+C           preceding parameters, or to .FALSE. otherwise.
+C           This will save time in case these checks have already
+C           been performed (say, in PCHIM or PCHIC).
+C           SKIP will be set to .TRUE. on normal return.
+C
+C     NE -- (input) number of evaluation points.  (Error return if
+C           NE.LT.1 .)
+C
+C     XE -- (input) real array of points at which the function is to be
+C           evaluated.
+C
+C          NOTES:
+C           1. The evaluation will be most efficient if the elements
+C              of XE are increasing relative to X;
+C              that is,   XE(J) .GE. X(I)
+C              implies    XE(K) .GE. X(I),  all K.GE.J .
+C           2. If any of the XE are outside the interval [X(1),X(N)],
+C              values are extrapolated from the nearest extreme cubic,
+C              and a warning error is returned.
+C
+C     FE -- (output) real array of values of the cubic Hermite function
+C           defined by  N, X, F, D  at the points  XE.
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           Warning error:
+C              IERR.GT.0  means that extrapolation was performed at
+C                 IERR points.
+C           "Recoverable" errors:
+C              IERR = -1  if N.LT.2 .
+C              IERR = -2  if INCFD.LT.1 .
+C              IERR = -3  if the X-array is not strictly increasing.
+C              IERR = -4  if NE.LT.1 .
+C             (The FE-array has not been changed in any of these cases.)
+C               NOTE:  The above errors are checked in the order listed,
+C                   and following arguments have **NOT** been validated.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  CHFEV, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   811020  DATE WRITTEN
+C   820803  Minor cosmetic changes for release 1.
+C   870707  Minor cosmetic changes to prologue.
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890831  Modified array declarations.  (WRB)
+C   890831  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  PCHFE
+C  Programming notes:
+C
+C     1. To produce a double precision version, simply:
+C        a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they
+C           occur,
+C        b. Change the real declaration to double precision,
+C
+C     2. Most of the coding between the call to CHFEV and the end of
+C        the IR-loop could be eliminated if it were permissible to
+C        assume that XE is ordered relative to X.
+C
+C     3. CHFEV does not assume that X1 is less than X2.  thus, it would
+C        be possible to write a version of PCHFE that assumes a strict-
+C        ly decreasing X-array by simply running the IR-loop backwards
+C        (and reversing the order of appropriate tests).
+C
+C     4. The present code has a minor bug, which I have decided is not
+C        worth the effort that would be required to fix it.
+C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
+C        X(N-1), followed by points .GT.X(N), the extrapolation points
+C        will be counted (at least) twice in the total returned in IERR.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  N, INCFD, NE, IERR
+      REAL  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
+      LOGICAL  SKIP
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHFE
+      IF (SKIP)  GO TO 5
+C
+      IF ( N.LT.2 )  GO TO 5001
+      IF ( INCFD.LT.1 )  GO TO 5002
+      DO 1  I = 2, N
+         IF ( X(I).LE.X(I-1) )  GO TO 5003
+    1 CONTINUE
+C
+C  FUNCTION DEFINITION IS OK, GO ON.
+C
+    5 CONTINUE
+      IF ( NE.LT.1 )  GO TO 5004
+      IERR = 0
+      SKIP = .TRUE.
+C
+C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
+C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
+      JFIRST = 1
+      IR = 2
+   10 CONTINUE
+C
+C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
+C
+         IF (JFIRST .GT. NE)  GO TO 5000
+C
+C     LOCATE ALL POINTS IN INTERVAL.
+C
+         DO 20  J = JFIRST, NE
+            IF (XE(J) .GE. X(IR))  GO TO 30
+   20    CONTINUE
+         J = NE + 1
+         GO TO 40
+C
+C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
+C
+   30    CONTINUE
+         IF (IR .EQ. N)  J = NE + 1
+C
+   40    CONTINUE
+         NJ = J - JFIRST
+C
+C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
+C
+         IF (NJ .EQ. 0)  GO TO 50
+C
+C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
+C
+C       ----------------------------------------------------------------
+        CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR),
+     *              NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
+C       ----------------------------------------------------------------
+         IF (IERC .LT. 0)  GO TO 5005
+C
+         IF (NEXT(2) .EQ. 0)  GO TO 42
+C        IF (NEXT(2) .GT. 0)  THEN
+C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
+C           RIGHT OF X(IR).
+C
+            IF (IR .LT. N)  GO TO 41
+C           IF (IR .EQ. N)  THEN
+C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+               IERR = IERR + NEXT(2)
+               GO TO 42
+   41       CONTINUE
+C           ELSE
+C              WE SHOULD NEVER HAVE GOTTEN HERE.
+               GO TO 5005
+C           ENDIF
+C        ENDIF
+   42    CONTINUE
+C
+         IF (NEXT(1) .EQ. 0)  GO TO 49
+C        IF (NEXT(1) .GT. 0)  THEN
+C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
+C           LEFT OF X(IR-1).
+C
+            IF (IR .GT. 2)  GO TO 43
+C           IF (IR .EQ. 2)  THEN
+C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+               IERR = IERR + NEXT(1)
+               GO TO 49
+   43       CONTINUE
+C           ELSE
+C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
+C              EVALUATION INTERVAL.
+C
+C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
+               DO 44  I = JFIRST, J-1
+                  IF (XE(I) .LT. X(IR-1))  GO TO 45
+   44          CONTINUE
+C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
+C                     IN CHFEV.
+               GO TO 5005
+C
+   45          CONTINUE
+C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
+               J = I
+C
+C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
+               DO 46  I = 1, IR-1
+                  IF (XE(J) .LT. X(I)) GO TO 47
+   46          CONTINUE
+C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
+C
+   47          CONTINUE
+C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
+C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
+C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
+C              CYCLING.
+               IR = MAX(1, I-1)
+C           ENDIF
+C        ENDIF
+   49    CONTINUE
+C
+         JFIRST = J
+C
+C     END OF IR-LOOP.
+C
+   50 CONTINUE
+      IR = IR + 1
+      IF (IR .LE. N)  GO TO 10
+C
+C  NORMAL RETURN.
+C
+ 5000 CONTINUE
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     N.LT.2 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     INCFD.LT.1 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR,
+     +   1)
+      RETURN
+C
+ 5003 CONTINUE
+C     X-ARRAY NOT STRICTLY INCREASING.
+      IERR = -3
+      CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING'
+     +   , IERR, 1)
+      RETURN
+C
+ 5004 CONTINUE
+C     NE.LT.1 RETURN.
+      IERR = -4
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+      RETURN
+C
+ 5005 CONTINUE
+C     ERROR RETURN FROM CHFEV.
+C   *** THIS CASE SHOULD NEVER OCCUR ***
+      IERR = -5
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2)
+      RETURN
+C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------
+      END
Index: LMDZ5/branches/testing/libf/misc/pchfe_95_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/pchfe_95_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pchfe_95_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/pchsp.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/pchsp.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pchsp.F	(revision 2298)
@@ -0,0 +1,388 @@
+*DECK PCHSP
+      SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+C***BEGIN PROLOGUE  PCHSP
+C***PURPOSE  Set derivatives needed to determine the Hermite represen-
+C            tation of the cubic spline interpolant to given data, with
+C            specified boundary conditions.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E1A
+C***TYPE      SINGLE PRECISION (PCHSP-S, DPCHSP-D)
+C***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
+C             PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          PCHSP:   Piecewise Cubic Hermite Spline
+C
+C     Computes the Hermite representation of the cubic spline inter-
+C     polant to the data given in X and F satisfying the boundary
+C     conditions specified by IC and VC.
+C
+C     To facilitate two-dimensional applications, includes an increment
+C     between successive values of the F- and D-arrays.
+C
+C     The resulting piecewise cubic Hermite function may be evaluated
+C     by PCHFE or PCHFD.
+C
+C     NOTE:  This is a modified version of C. de Boor's cubic spline
+C            routine CUBSPL.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        PARAMETER  (INCFD = ...)
+C        INTEGER  IC(2), N, NWK, IERR
+C        REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
+C
+C        CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+C
+C   Parameters:
+C
+C     IC -- (input) integer array of length 2 specifying desired
+C           boundary conditions:
+C           IC(1) = IBEG, desired condition at beginning of data.
+C           IC(2) = IEND, desired condition at end of data.
+C
+C           IBEG = 0  to set D(1) so that the third derivative is con-
+C              tinuous at X(2).  This is the "not a knot" condition
+C              provided by de Boor's cubic spline routine CUBSPL.
+C              < This is the default boundary condition. >
+C           IBEG = 1  if first derivative at X(1) is given in VC(1).
+C           IBEG = 2  if second derivative at X(1) is given in VC(1).
+C           IBEG = 3  to use the 3-point difference formula for D(1).
+C                     (Reverts to the default b.c. if N.LT.3 .)
+C           IBEG = 4  to use the 4-point difference formula for D(1).
+C                     (Reverts to the default b.c. if N.LT.4 .)
+C          NOTES:
+C           1. An error return is taken if IBEG is out of range.
+C           2. For the "natural" boundary condition, use IBEG=2 and
+C              VC(1)=0.
+C
+C           IEND may take on the same values as IBEG, but applied to
+C           derivative at X(N).  In case IEND = 1 or 2, the value is
+C           given in VC(2).
+C
+C          NOTES:
+C           1. An error return is taken if IEND is out of range.
+C           2. For the "natural" boundary condition, use IEND=2 and
+C              VC(2)=0.
+C
+C     VC -- (input) real array of length 2 specifying desired boundary
+C           values, as indicated above.
+C           VC(1) need be set only if IC(1) = 1 or 2 .
+C           VC(2) need be set only if IC(2) = 1 or 2 .
+C
+C     N -- (input) number of data points.  (Error return if N.LT.2 .)
+C
+C     X -- (input) real array of independent variable values.  The
+C           elements of X must be strictly increasing:
+C                X(I-1) .LT. X(I),  I = 2(1)N.
+C           (Error return if not.)
+C
+C     F -- (input) real array of dependent variable values to be inter-
+C           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
+C
+C     D -- (output) real array of derivative values at the data points.
+C           These values will determine the cubic spline interpolant
+C           with the requested boundary conditions.
+C           The value corresponding to X(I) is stored in
+C                D(1+(I-1)*INCFD),  I=1(1)N.
+C           No other entries in D are changed.
+C
+C     INCFD -- (input) increment between successive values in F and D.
+C           This argument is provided primarily for 2-D applications.
+C           (Error return if  INCFD.LT.1 .)
+C
+C     WK -- (scratch) real array of working storage.
+C
+C     NWK -- (input) length of work array.
+C           (Error return if NWK.LT.2*N .)
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           "Recoverable" errors:
+C              IERR = -1  if N.LT.2 .
+C              IERR = -2  if INCFD.LT.1 .
+C              IERR = -3  if the X-array is not strictly increasing.
+C              IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
+C              IERR = -5  if IEND.LT.0 of IEND.GT.4 .
+C              IERR = -6  if both of the above are true.
+C              IERR = -7  if NWK is too small.
+C               NOTE:  The above errors are checked in the order listed,
+C                   and following arguments have **NOT** been validated.
+C             (The D-array has not been changed in any of these cases.)
+C              IERR = -8  in case of trouble solving the linear system
+C                         for the interior derivative values.
+C             (The D-array may have been changed in this case.)
+C             (             Do **NOT** use it!                )
+C
+C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+C                 Verlag, New York, 1978, pp. 53-59.
+C***ROUTINES CALLED  PCHDF, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   820503  DATE WRITTEN
+C   820804  Converted to SLATEC library version.
+C   870707  Minor cosmetic changes to prologue.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890703  Corrected category record.  (WRB)
+C   890831  Modified array declarations.  (WRB)
+C   890831  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   920429  Revised format and order of references.  (WRB,FNF)
+C***END PROLOGUE  PCHSP
+C  Programming notes:
+C
+C     To produce a double precision version, simply:
+C        a. Change PCHSP to DPCHSP wherever it occurs,
+C        b. Change the real declarations to double precision, and
+C        c. Change the constants ZERO, HALF, ... to double precision.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  IC(2), N, INCFD, NWK, IERR
+      REAL  VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  IBEG, IEND, INDEX, J, NM1
+      REAL  G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO
+      SAVE ZERO, HALF, ONE, TWO, THREE
+      REAL  PCHDF
+C
+      DATA  ZERO /0./,  HALF /0.5/,  ONE /1./,  TWO /2./,  THREE /3./
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHSP
+      IF ( N.LT.2 )  GO TO 5001
+      IF ( INCFD.LT.1 )  GO TO 5002
+      DO 1  J = 2, N
+         IF ( X(J).LE.X(J-1) )  GO TO 5003
+    1 CONTINUE
+C
+      IBEG = IC(1)
+      IEND = IC(2)
+      IERR = 0
+      IF ( (IBEG.LT.0).OR.(IBEG.GT.4) )  IERR = IERR - 1
+      IF ( (IEND.LT.0).OR.(IEND.GT.4) )  IERR = IERR - 2
+      IF ( IERR.LT.0 )  GO TO 5004
+C
+C  FUNCTION DEFINITION IS OK -- GO ON.
+C
+      IF ( NWK .LT. 2*N )  GO TO 5007
+C
+C  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
+C  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
+      DO 5  J=2,N
+         WK(1,J) = X(J) - X(J-1)
+         WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
+    5 CONTINUE
+C
+C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
+C
+      IF ( IBEG.GT.N )  IBEG = 0
+      IF ( IEND.GT.N )  IEND = 0
+C
+C  SET UP FOR BOUNDARY CONDITIONS.
+C
+      IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) )  THEN
+         D(1,1) = VC(1)
+      ELSE IF (IBEG .GT. 2)  THEN
+C        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
+         DO 10  J = 1, IBEG
+            INDEX = IBEG-J+1
+C           INDEX RUNS FROM IBEG DOWN TO 1.
+            XTEMP(J) = X(INDEX)
+            IF (J .LT. IBEG)  STEMP(J) = WK(2,INDEX)
+   10    CONTINUE
+C                 --------------------------------
+         D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR)
+C                 --------------------------------
+         IF (IERR .NE. 0)  GO TO 5009
+         IBEG = 1
+      ENDIF
+C
+      IF ( (IEND.EQ.1).OR.(IEND.EQ.2) )  THEN
+         D(1,N) = VC(2)
+      ELSE IF (IEND .GT. 2)  THEN
+C        PICK UP LAST IEND POINTS.
+         DO 15  J = 1, IEND
+            INDEX = N-IEND+J
+C           INDEX RUNS FROM N+1-IEND UP TO N.
+            XTEMP(J) = X(INDEX)
+            IF (J .LT. IEND)  STEMP(J) = WK(2,INDEX+1)
+   15    CONTINUE
+C                 --------------------------------
+         D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR)
+C                 --------------------------------
+         IF (IERR .NE. 0)  GO TO 5009
+         IEND = 1
+      ENDIF
+C
+C --------------------( BEGIN CODING FROM CUBSPL )--------------------
+C
+C  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
+C  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
+C  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
+C     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
+C
+C  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
+C             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
+C
+      IF (IBEG .EQ. 0)  THEN
+         IF (N .EQ. 2)  THEN
+C           NO CONDITION AT LEFT END AND N = 2.
+            WK(2,1) = ONE
+            WK(1,1) = ONE
+            D(1,1) = TWO*WK(2,2)
+         ELSE
+C           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
+            WK(2,1) = WK(1,3)
+            WK(1,1) = WK(1,2) + WK(1,3)
+            D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3)
+     *                        + WK(1,2)**2*WK(2,3)) / WK(1,1)
+         ENDIF
+      ELSE IF (IBEG .EQ. 1)  THEN
+C        SLOPE PRESCRIBED AT LEFT END.
+         WK(2,1) = ONE
+         WK(1,1) = ZERO
+      ELSE
+C        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
+         WK(2,1) = TWO
+         WK(1,1) = ONE
+         D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
+      ENDIF
+C
+C  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
+C  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
+C  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
+C
+      NM1 = N-1
+      IF (NM1 .GT. 1)  THEN
+         DO 20 J=2,NM1
+            IF (WK(2,J-1) .EQ. ZERO)  GO TO 5008
+            G = -WK(1,J+1)/WK(2,J-1)
+            D(1,J) = G*D(1,J-1)
+     *                  + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
+            WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
+   20    CONTINUE
+      ENDIF
+C
+C  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
+C           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
+C
+C     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
+C     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
+C     AT THIS POINT.
+      IF (IEND .EQ. 1)  GO TO 30
+C
+      IF (IEND .EQ. 0)  THEN
+         IF (N.EQ.2 .AND. IBEG.EQ.0)  THEN
+C           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
+            D(1,2) = WK(2,2)
+            GO TO 30
+         ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0))  THEN
+C           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
+C           NOT-A-KNOT AT LEFT END POINT).
+            D(1,N) = TWO*WK(2,N)
+            WK(2,N) = ONE
+            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+            G = -ONE/WK(2,N-1)
+         ELSE
+C           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
+C           KNOT AT LEFT END POINT.
+            G = WK(1,N-1) + WK(1,N)
+C           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
+            D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
+     *                  + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
+            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+            G = -G/WK(2,N-1)
+            WK(2,N) = WK(1,N-1)
+         ENDIF
+      ELSE
+C        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
+         D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
+         WK(2,N) = TWO
+         IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+         G = -ONE/WK(2,N-1)
+      ENDIF
+C
+C  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
+C
+      WK(2,N) = G*WK(1,N-1) + WK(2,N)
+      IF (WK(2,N) .EQ. ZERO)   GO TO 5008
+      D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
+C
+C  CARRY OUT BACK SUBSTITUTION
+C
+   30 CONTINUE
+      DO 40 J=NM1,1,-1
+         IF (WK(2,J) .EQ. ZERO)  GO TO 5008
+         D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
+   40 CONTINUE
+C --------------------(  END  CODING FROM CUBSPL )--------------------
+C
+C  NORMAL RETURN.
+C
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     N.LT.2 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHSP',
+     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     INCFD.LT.1 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR,
+     +   1)
+      RETURN
+C
+ 5003 CONTINUE
+C     X-ARRAY NOT STRICTLY INCREASING.
+      IERR = -3
+      CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING'
+     +   , IERR, 1)
+      RETURN
+C
+ 5004 CONTINUE
+C     IC OUT OF RANGE RETURN.
+      IERR = IERR - 3
+      CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1)
+      RETURN
+C
+ 5007 CONTINUE
+C     NWK TOO SMALL RETURN.
+      IERR = -7
+      CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
+      RETURN
+C
+ 5008 CONTINUE
+C     SINGULAR SYSTEM.
+C   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
+C   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
+      IERR = -8
+      CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR,
+     +   1)
+      RETURN
+C
+ 5009 CONTINUE
+C     ERROR RETURN FROM PCHDF.
+C   *** THIS CASE SHOULD NEVER OCCUR ***
+      IERR = -9
+      CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR,
+     +   1)
+      RETURN
+C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
+      END
Index: LMDZ5/branches/testing/libf/misc/pchsp_95_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/pchsp_95_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pchsp_95_m.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/pres2lev_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/pres2lev_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/pres2lev_mod.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/misc/ran1.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/ran1.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/ran1.F	(revision 2298)
@@ -0,0 +1,38 @@
+!
+! $Id$
+!
+      FUNCTION RAN1(IDUM)
+      IMPLICIT NONE
+      REAL RAN1
+      REAL,SAVE :: R(97)
+      REAL,PARAMETER :: RM1=3.8580247E-6,RM2=7.4373773E-6
+      INTEGER,SAVE :: IFF=0
+      integer,save :: ix1,ix2,ix3
+      INTEGER,PARAMETER :: M1=259200,IA1=7141,IC1=54773
+      INTEGER,PARAMETER :: M2=134456,IA2=8121,IC2=28411
+      INTEGER,PARAMETER :: M3=243000,IA3=4561,IC3=51349
+      INTEGER :: IDUM,J
+
+      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
+        IFF=1
+        IX1=MOD(IC1-IDUM,M1)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX2=MOD(IX1,M2)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX3=MOD(IX1,M3)
+        DO 11 J=1,97
+          IX1=MOD(IA1*IX1+IC1,M1)
+          IX2=MOD(IA2*IX2+IC2,M2)
+          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+11      CONTINUE
+        IDUM=1
+      ENDIF
+      IX1=MOD(IA1*IX1+IC1,M1)
+      IX2=MOD(IA2*IX2+IC2,M2)
+      IX3=MOD(IA3*IX3+IC3,M3)
+      J=1+(97*IX3)/M3
+      IF(J.GT.97.OR.J.LT.1) stop 1
+      RAN1=R(J)
+      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/regr1_lint_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/regr1_lint_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/regr1_lint_m.F90	(revision 2298)
@@ -0,0 +1,98 @@
+! $Id$
+module regr1_lint_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_lint
+     ! Each procedure regrids by linear interpolation.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! The difference betwwen the procedures is the rank of the first argument.
+     module procedure regr11_lint, regr12_lint
+  end interface
+
+  private
+  public regr1_lint
+
+contains
+
+  function regr11_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt !!, polint
+
+    real, intent(in):: vs(:)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs), size(xs), "regr11_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+!!       call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it))
+       vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr11_lint
+
+  !*********************************************************
+
+  function regr12_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt), size(vs, 2)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr12_lint
+
+end module regr1_lint_m
Index: LMDZ5/branches/testing/libf/misc/regr1_step_av_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/regr1_step_av_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/regr1_step_av_m.F90	(revision 2298)
@@ -0,0 +1,268 @@
+! $Id$
+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: LMDZ5/branches/testing/libf/misc/regr3_lint_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/regr3_lint_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/regr3_lint_m.F90	(revision 2298)
@@ -0,0 +1,100 @@
+! $Id$
+module regr3_lint_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr3_lint
+     ! Each procedure regrids by linear interpolation.
+     ! The regridding operation is done on the third dimension of the
+     ! input array.
+     ! The difference betwwen the procedures is the rank of the first argument.
+     module procedure regr33_lint, regr34_lint
+  end interface
+
+  private
+  public regr3_lint
+
+contains
+
+  function regr33_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 3.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(vs, 1), size(vs, 2), size(xt))
+    ! (values of the function on the target grid)
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) &
+            + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr33_lint
+
+  !*********************************************************
+
+  function regr34_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 4.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :, :, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4))
+    ! (values of the function on the target grid)
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) &
+            + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) &
+            / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr34_lint
+
+end module regr3_lint_m
Index: LMDZ5/branches/testing/libf/misc/simple.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/simple.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/simple.F90	(revision 2298)
@@ -0,0 +1,361 @@
+! $Id$
+module simple
+
+  use handle_err_m, only: handle_err
+  
+  implicit none
+
+  private handle_err
+
+contains
+
+  subroutine nf95_open(path, mode, ncid, chunksize, ncerr)
+
+    use netcdf, only: nf90_open
+
+    character(len=*), intent(in):: path
+    integer, intent(in):: mode
+    integer, intent(out):: ncid
+    integer, intent(inout), optional:: chunksize
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_open(path, mode, ncid, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_open " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_open
+
+  !************************
+
+  subroutine nf95_inq_dimid(ncid, name, dimid, ncerr)
+
+    use netcdf, only: nf90_inq_dimid
+
+    integer,             intent(in) :: ncid
+    character (len = *), intent(in) :: name
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_dimid " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_dimid
+
+  !************************
+
+  subroutine nf95_inquire_dimension(ncid, dimid, name, nclen, ncerr)
+
+    use netcdf, only: nf90_inquire_dimension
+
+    integer,                       intent( in) :: ncid, dimid
+    character (len = *), optional, intent(out) :: name
+    integer,             optional, intent(out) :: nclen
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, nclen)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire_dimension
+
+  !************************
+
+  subroutine nf95_inq_varid(ncid, name, varid, ncerr)
+
+    use netcdf, only: nf90_inq_varid
+
+    integer,             intent(in) :: ncid
+    character(len=*), intent(in):: name
+    integer,             intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_varid(ncid, name, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_varid
+
+  !************************
+
+  subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, &
+       nAtts, ncerr)
+
+    ! In "nf90_inquire_variable", "dimids" is an assumed-size array.
+    ! This is not optimal.
+    ! We are in the classical case of an array the size of which is
+    ! unknown in the calling procedure, before the call.
+    ! Here we use a better solution: a pointer argument array.
+    ! This procedure associates and defines "dimids" if it is present.
+
+    use netcdf, only: nf90_inquire_variable, nf90_max_var_dims
+
+    integer, intent(in):: ncid, varid
+    character(len = *), optional, intent(out):: name
+    integer, optional, intent(out) :: xtype, ndims
+    integer, dimension(:), optional, pointer :: dimids
+    integer, optional, intent(out) :: nAtts
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+    integer dimids_local(nf90_max_var_dims)
+    integer ndims_not_opt
+
+    !-------------------
+
+    if (present(dimids)) then
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, &
+            ndims_not_opt, dimids_local, nAtts)
+       allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0
+       dimids = dimids_local(:ndims_not_opt)
+       if (present(ndims)) ndims = ndims_not_opt
+    else
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, &
+            nAtts=nAtts)
+    end if
+
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_variable
+
+  !************************
+
+  subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr)
+    
+    use netcdf, only: nf90_create
+
+    character (len = *), intent(in   ) :: path
+    integer,             intent(in   ) :: cmode
+    integer,             intent(  out) :: ncid
+    integer, optional,   intent(in   ) :: initialsize
+    integer, optional,   intent(inout) :: chunksize
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_create " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_create
+
+  !************************
+
+  subroutine nf95_def_dim(ncid, name, nclen, dimid, ncerr)
+
+    use netcdf, only: nf90_def_dim
+
+    integer,             intent( in) :: ncid
+    character (len = *), intent( in) :: name
+    integer,             intent( in) :: nclen
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_dim(ncid, name, nclen, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_dim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_dim
+
+  !***********************
+
+  subroutine nf95_redef(ncid, ncerr)
+
+    use netcdf, only: nf90_redef
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_redef(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_redef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_redef
+  
+  !***********************
+
+  subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr)
+
+    use netcdf, only: nf90_enddef
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_enddef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_enddef
+
+  !***********************
+
+  subroutine nf95_close(ncid, ncerr)
+
+    use netcdf, only: nf90_close
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_close(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_close", ncerr_not_opt)
+    end if
+
+  end subroutine nf95_close
+
+  !***********************
+
+  subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr)
+
+    use netcdf, only: nf90_copy_att
+
+    integer, intent( in):: ncid_in,  varid_in
+    character(len=*), intent( in):: name
+    integer, intent( in):: ncid_out, varid_out
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_copy_att " // name, ncerr_not_opt, ncid_out)
+    end if
+
+  end subroutine nf95_copy_att
+
+  !***********************
+
+  subroutine nf95_inquire_attribute(ncid, varid, name, xtype, nclen, attnum, &
+       ncerr)
+
+    use netcdf, only: nf90_inquire_attribute
+
+    integer,             intent( in)           :: ncid, varid
+    character (len = *), intent( in)           :: name
+    integer,             intent(out), optional :: xtype, nclen, attnum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, xtype, nclen, &
+         attnum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_attribute " // name, ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_attribute
+
+  !***********************
+
+  subroutine nf95_inquire(ncid, nDimensions, nVariables, nAttributes, &
+       unlimitedDimId, formatNum, ncerr)
+
+    use netcdf, only: nf90_inquire
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent(out) :: nDimensions, nVariables, nAttributes
+    integer, optional, intent(out) :: unlimitedDimId, formatNum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire(ncid, nDimensions, nVariables, nAttributes, &
+         unlimitedDimId, formatNum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire
+
+end module simple
Index: LMDZ5/branches/testing/libf/misc/sort.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/sort.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/sort.F	(revision 2298)
@@ -0,0 +1,37 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE sort(n,d)
+c
+c     P.Le Van
+c      
+c...  cette routine met le tableau d  dans l'ordre croissant  ....
+cc   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
+c      tion  situee + bas  IF(d(j).LE.p)  THEN     par
+c                           IF(d(j).GE.p)  THEN
+c
+
+      INTEGER n
+      REAL d(n) , p
+      INTEGER i,j,k
+
+      DO i=1,n-1
+        k=i
+        p=d(i)
+        DO j=i+1,n
+         IF(d(j).LE.p) THEN
+           k=j
+           p=d(j)
+         ENDIF
+        ENDDO
+
+       IF(k.ne.i) THEN
+         d(k)=d(i)
+         d(i)=p
+       ENDIF
+      ENDDO
+
+       RETURN
+       END
Index: LMDZ5/branches/testing/libf/misc/vampir.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/vampir.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/vampir.F90	(revision 2298)
@@ -0,0 +1,86 @@
+module Vampir
+
+  INTEGER,parameter :: VTcaldyn=1
+  INTEGER,parameter :: VTintegre=2
+  INTEGER,parameter :: VTadvection=3
+  INTEGER,parameter :: VTdissipation=4
+  INTEGER,parameter :: VThallo=5
+  INTEGER,parameter :: VTphysiq=6
+  INTEGER,parameter :: VTinca=7
+  
+  INTEGER,parameter :: nb_inst=7
+  INTEGER :: MPE_begin(nb_inst)
+  INTEGER :: MPE_end(nb_inst)
+  
+contains
+
+  subroutine InitVampir
+    implicit none
+
+#ifdef USE_VT
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr)
+    call VTSYMDEF(VTintegre,"integre","integre",ierr)
+    call VTSYMDEF(VTadvection,"advection","advection",ierr)
+    call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr)
+    call VTSYMDEF(VThallo,"hallo","hallo",ierr)
+    call VTSYMDEF(VTphysiq,"physiq","physiq",ierr)
+    call VTSYMDEF(VTinca,"inca","inca",ierr)
+#endif
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    
+    DO i=1,nb_inst
+      ierr = MPE_Log_get_state_eventIDs( MPE_begin(i), MPE_end(i) )
+    ENDDO
+    
+    ierr = MPE_Describe_state( MPE_begin(VTcaldyn), MPE_end(VTcaldyn),"caldyn", "yellow" )
+    ierr = MPE_Describe_state( MPE_begin(VTintegre), MPE_end(VTintegre),"integre", "blue" )
+    ierr = MPE_Describe_state( MPE_begin(VTadvection), MPE_end(VTadvection),"advection", "green" )
+    ierr = MPE_Describe_state( MPE_begin(VTdissipation), MPE_end(VTdissipation),"dissipation", "ivory" )
+    ierr = MPE_Describe_state( MPE_begin(VThallo), MPE_end(VThallo),"hallo", "orange" )
+    ierr = MPE_Describe_state( MPE_begin(VTphysiq), MPE_end(VTphysiq),"physiq", "purple" )
+    ierr = MPE_Describe_state( MPE_begin(VTinca), MPE_end(VTinca),"inca", "LightBlue" )
+#endif     
+  end subroutine InitVampir
+
+  subroutine VTb(number)
+    implicit none
+    INTEGER :: number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTBEGIN(number,ierr)
+#endif 
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_begin(number), 0, '' )
+#endif
+
+  end subroutine VTb
+
+  subroutine VTe(number)
+    implicit none
+    INTEGER :: Number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+   
+    call VTEND(number,ierr)
+#endif    
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_end(number), 0, '' )
+#endif
+
+  end subroutine VTe
+  
+end module Vampir
Index: LMDZ5/branches/testing/libf/misc/wxios.F90
===================================================================
--- LMDZ5/branches/testing/libf/misc/wxios.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/wxios.F90	(revision 2298)
@@ -0,0 +1,576 @@
+! $Id: wxios.F90 $
+#ifdef CPP_XIOS
+MODULE wxios
+    USE xios
+    USE iaxis
+    USE iaxis_attr
+    USE icontext_attr
+    USE idate
+    USE idomain_attr
+    USE ifield_attr
+    USE ifile_attr
+    USE ixml_tree
+
+    !Variables disponibles pendant toute l'execution du programme:
+    
+    INTEGER, SAVE :: g_comm
+    CHARACTER(len=100), SAVE :: g_ctx_name
+    TYPE(xios_context), SAVE :: g_ctx
+!$OMP THREADPRIVATE(g_comm,g_cts_name,g_ctx)
+    LOGICAL, SAVE :: g_flag_xml = .FALSE.
+    CHARACTER(len=100) :: g_field_name = "nofield"
+!$OMP THREADPRIVATE(g_flag_xml,g_field_name)
+    REAL :: missing_val_omp
+    REAL :: missing_val
+!$OMP THREADPRIVATE(missing_val)
+
+    CONTAINS
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !   36day => 36d etc     !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    
+    SUBROUTINE reformadate(odate, ndate)
+        CHARACTER(len=*), INTENT(IN) :: odate
+        CHARACTER(len=100), INTENT(OUT) :: ndate
+        
+        INTEGER :: i = 0
+         !!!!!!!!!!!!!!!!!!
+         ! Pour XIOS:
+         !  year : y
+         !  month : mo
+         !  day : d
+         !  hour : h
+         !  minute : mi
+         !  second : s
+         !!!!!!!!!!!!!!!!!!
+
+        i = INDEX(odate, "day")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"d"
+        END IF
+
+        i = INDEX(odate, "hr")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"h"
+        END IF
+
+        i = INDEX(odate, "mth")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"mo"
+        END IF
+        
+        !IF (prt_level >= 10) WRITE(lunout,*) "Xios. ", odate, " => ", ndate
+    END SUBROUTINE reformadate
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !   ave(X) => average etc     !!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    
+    CHARACTER(len=7) FUNCTION reformaop(op)
+        CHARACTER(len=*), INTENT(IN) :: op
+        
+        INTEGER :: i = 0
+        reformaop = "average"
+        
+        IF (op.EQ."inst(X)") THEN
+            reformaop = "instant"
+        END IF
+        
+        IF (op.EQ."once") THEN
+            reformaop = "once"
+        END IF
+        
+        IF (op.EQ."t_max(X)") THEN
+            reformaop = "maximum"
+        END IF
+        
+        IF (op.EQ."t_min(X)") THEN
+            reformaop = "minimum"
+        END IF
+        
+        !IF (prt_level >= 10) WRITE(lunout,*) "Xios. ", op, " => ", reformaop
+    END FUNCTION reformaop
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Routine d'initialisation      !!!!!!!!!!!!!
+    !     A lancer juste après mpi_init !!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wxios_init(xios_ctx_name, locom, outcom, type_ocean)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+      CHARACTER(len=*), INTENT(IN) :: xios_ctx_name
+      INTEGER, INTENT(IN), OPTIONAL :: locom
+      INTEGER, INTENT(OUT), OPTIONAL :: outcom
+      CHARACTER(len=6), INTENT(IN), OPTIONAL :: type_ocean
+
+    
+        TYPE(xios_context) :: xios_ctx
+        INTEGER :: xios_comm
+
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: Initialization"
+
+
+
+        IF (PRESENT(locom)) THEN
+          CALL xios_initialize(xios_ctx_name, local_comm = locom, return_comm = xios_comm )
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," local_comm=",locom,", return_comm=",xios_comm
+        ELSE
+          CALL xios_initialize(xios_ctx_name, return_comm = xios_comm )
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," return_comm=",xios_comm
+        END IF
+        
+        IF (PRESENT(outcom)) THEN
+          outcom = xios_comm
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," outcom=",outcom
+        END IF
+        
+        !Enregistrement des variables globales:
+        g_comm = xios_comm
+        g_ctx_name = xios_ctx_name
+        
+        ! Si couple alors init fait dans cpl_init
+        IF (.not. PRESENT(type_ocean)) THEN
+            CALL wxios_context_init()
+        ENDIF
+
+    END SUBROUTINE wxios_init
+
+    SUBROUTINE wxios_context_init()
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        TYPE(xios_context) :: xios_ctx
+
+        !Initialisation du contexte:
+        CALL xios_context_initialize(g_ctx_name, g_comm)
+        CALL xios_get_handle(g_ctx_name, xios_ctx)    !Récupération
+        CALL xios_set_current_context(xios_ctx)            !Activation
+        g_ctx = xios_ctx
+
+        IF (prt_level >= 10) THEN
+          WRITE(lunout,*) "wxios_context_init: Current context is ",trim(g_ctx_name)
+          WRITE(lunout,*) "     now call xios_solve_inheritance()"
+        ENDIF
+        !Une première analyse des héritages:
+        CALL xios_solve_inheritance()
+    END SUBROUTINE wxios_context_init
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Routine de paramétrisation !!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wxios_set_cal(pasdetemps, calendrier, annee, mois, jour, heure, ini_an, ini_mois, ini_jour, ini_heure)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+     !Paramètres:
+     CHARACTER(len=*), INTENT(IN) :: calendrier
+     INTEGER, INTENT(IN) :: annee, mois, jour, ini_an, ini_mois, ini_jour
+     REAL, INTENT(IN) :: pasdetemps, heure, ini_heure
+     
+     !Variables:
+     CHARACTER(len=80) :: abort_message
+     CHARACTER(len=19) :: date
+     INTEGER :: njour = 1
+     
+     !Variables pour xios:
+     TYPE(xios_time) :: mdtime
+     !REAL(kind = 8) :: year=0, month=0, day=0, hour=0, minute=0, second=0
+     
+        mdtime = xios_time(0, 0, 0, 0, 0, pasdetemps)
+
+        !Réglage du calendrier:
+        SELECT CASE (calendrier)
+            CASE('earth_360d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "D360")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier terrestre a 360 jours/an'
+            CASE('earth_365d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "NoLeap")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier terrestre a 365 jours/an'
+            CASE('earth_366d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "Gregorian")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier gregorien'
+            CASE DEFAULT
+                abort_message = 'wxios_set_cal: Mauvais choix de calendrier'
+                CALL abort_gcm('Gcm:Xios',abort_message,1)
+        END SELECT
+        
+        !Formatage de la date d'origine:
+        WRITE(date, "(i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':00:00')") annee, mois, jour, int(heure)
+        
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_set_cal: Time origin: ", date
+        
+        CALL xios_set_context_attr_hdl(g_ctx, time_origin = date)
+
+        !Formatage de la date de debut:
+
+        WRITE(date, "(i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':00:00')") ini_an, ini_mois, ini_jour, int(ini_heure)
+        
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_set_cal: Start date: ", date
+        
+        CALL xios_set_context_attr_hdl(g_ctx, start_date = date)
+        
+        !Et enfin,le pas de temps:
+        CALL xios_set_timestep(mdtime)
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_set_cal: ts=",mdtime
+    END SUBROUTINE wxios_set_cal
+
+    SUBROUTINE wxios_set_timestep(ts)
+        REAL, INTENT(IN) :: ts
+        TYPE(xios_time) :: mdtime     
+
+        mdtime = xios_time(0, 0, 0, 0, 0, ts)
+
+        CALL xios_set_timestep(mdtime)
+    END SUBROUTINE wxios_set_timestep
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour initialiser un domaine !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_domain_param(dom_id, is_sequential, ni, nj, ni_glo, nj_glo,        &
+                                    ibegin, iend, ii_begin, ii_end, jbegin, jend,       &
+                                    data_ni, data_ibegin, data_iend,                    &
+                                    io_lat, io_lon,is_south_pole,mpi_rank)
+         
+
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*),INTENT(IN) :: dom_id ! domain identifier
+        LOGICAL,INTENT(IN) :: is_sequential ! flag
+        INTEGER,INTENT(IN) :: ni ! local MPI domain number of longitudes
+        INTEGER,INTENT(IN) :: nj ! local MPI domain number of latitudes
+        INTEGER,INTENT(IN) :: ni_glo ! global grid number of longitudes
+        INTEGER,INTENT(IN) :: nj_glo ! global grid number of latitudes
+        INTEGER,INTENT(IN) :: ibegin ! start index, on global grid, of local MPI domain 
+        INTEGER,INTENT(IN) :: iend ! end index, on global grid, of local MPI domain
+        INTEGER,INTENT(IN) :: ii_begin ! i index at which local data starts (first row)
+        INTEGER,INTENT(IN) :: ii_end ! i index at which local data ends (last row)
+        INTEGER,INTENT(IN) :: jbegin ! start index, on global grid, of local MPI domain 
+        INTEGER,INTENT(IN) :: jend ! end index, on global grid, of local MPI domain
+        INTEGER,INTENT(IN) :: data_ni
+        INTEGER,INTENT(IN) :: data_ibegin
+        INTEGER,INTENT(IN) :: data_iend
+        REAL,INTENT(IN) :: io_lat(:) ! latitudes (of global grid)
+        REAL,INTENT(IN) :: io_lon(:) ! longitudes (of global grid)
+        logical,intent(in) :: is_south_pole ! does this process include the south pole?
+        integer,intent(in) :: mpi_rank ! rank of process
+        
+        TYPE(xios_domain) :: dom
+        LOGICAL :: boool
+        
+        !Masque pour les problèmes de recouvrement MPI:
+        LOGICAL :: mask(ni,nj)
+        
+        !On récupère le handle:
+        CALL xios_get_domain_handle(dom_id, dom)
+        
+        IF (prt_level >= 10) THEN
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ni:",ni," ni_glo:", ni_glo, " nj:", nj, " nj_glo:", nj_glo
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ibegin:",ibegin," iend:", iend, " jbegin:", jbegin, " jend:", jend
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ii_begin:",ii_begin," ii_end:", ii_end
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," Size io_lon:", SIZE(io_lon(ibegin:iend)), " io_lat:", SIZE(io_lat(jbegin:jend))
+        ENDIF
+        
+        !On parametrise le domaine:
+        CALL xios_set_domain_attr_hdl(dom, ni_glo=ni_glo, ibegin=ibegin, ni=ni)
+        CALL xios_set_domain_attr_hdl(dom, nj_glo=nj_glo, jbegin=jbegin, nj=nj, data_dim=2)
+        CALL xios_set_domain_attr_hdl(dom, lonvalue=io_lon(ibegin:iend), latvalue=io_lat(jbegin:jend))
+
+        IF (.NOT.is_sequential) THEN
+            mask(:,:)=.TRUE.
+            if (ii_begin>1) mask(1:ii_begin-1,1) = .FALSE.
+            if (ii_end<ni) mask(ii_end+1:ni,nj) = .FALSE.
+            ! special case for south pole
+            if ((ii_end.eq.1).and.(is_south_pole)) mask(1:ni,nj)=.true.
+            IF (prt_level >= 10) THEN
+              WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,1)=",mask(:,1)
+              WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,nj)=",mask(:,nj)
+            ENDIF
+            CALL xios_set_domain_attr_hdl(dom, mask=mask)
+        END IF
+
+         CALL xios_is_defined_domain_attr_hdl(dom,ni_glo=boool)
+        !Vérification:
+        IF (xios_is_valid_domain(dom_id)) THEN
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_domain_param: Domain initialized: ", trim(dom_id), boool
+        ELSE
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_domain_param: Invalid domain: ", trim(dom_id)
+        END IF
+    END SUBROUTINE wxios_domain_param
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour déclarer un axe vertical !!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_vaxis(axis_id, axis_size, axis_value)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER (len=*), INTENT(IN) :: axis_id
+        INTEGER, INTENT(IN) :: axis_size
+        REAL, DIMENSION(axis_size), INTENT(IN) :: axis_value
+        
+!        TYPE(xios_axisgroup) :: axgroup
+!        TYPE(xios_axis) :: ax
+!        CHARACTER(len=50) :: axis_id 
+        
+!        IF (len_trim(axisgroup_id).gt.len(axis_id)) THEN
+!          WRITE(lunout,*) "wxios_add_vaxis: error, size of axis_id too small!!"
+!          WRITE(lunout,*) "     increase it to at least ",len_trim(axisgroup_id)
+!          CALL abort_gcm("wxios_add_vaxis","len(axis_id) too small",1)
+!        ENDIF
+!        axis_id=trim(axisgroup_id)
+        
+        !On récupère le groupe d'axes qui va bien:
+        !CALL xios_get_axisgroup_handle(axisgroup_id, axgroup)
+        
+        !On ajoute l'axe correspondant à ce fichier:
+        !CALL xios_add_axis(axgroup, ax, TRIM(ADJUSTL(axis_id)))
+        
+        !Et on le parametrise:
+        !CALL xios_set_axis_attr_hdl(ax, size=axis_size, value=axis_value)
+        
+        ! Ehouarn: New way to declare axis, without axis_group:
+        CALL xios_set_axis_attr(trim(axis_id),size=axis_size,value=axis_value)
+        
+        !Vérification:
+        IF (xios_is_valid_axis(TRIM(ADJUSTL(axis_id)))) THEN
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_vaxis: Axis created: ", TRIM(ADJUSTL(axis_id))
+        ELSE
+            WRITE(lunout,*) "wxios_add_vaxis: Invalid axis: ", TRIM(ADJUSTL(axis_id))
+        END IF
+
+    END SUBROUTINE wxios_add_vaxis
+    
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour déclarer un fichier  !!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_file(fname, ffreq, flvl)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*), INTENT(IN) :: fname
+        CHARACTER(len=*), INTENT(IN) :: ffreq
+        INTEGER, INTENT(IN) :: flvl
+        
+        TYPE(xios_file) :: x_file
+        TYPE(xios_filegroup) :: x_fg
+        CHARACTER(len=100) :: nffreq
+        
+        !On regarde si le fichier n'est pas défini par XML:
+        IF (.NOT.xios_is_valid_file(fname)) THEN
+            !On créé le noeud:
+            CALL xios_get_filegroup_handle("defile", x_fg)
+            CALL xios_add_file(x_fg, x_file, fname)
+        
+            !On reformate la fréquence:
+            CALL reformadate(ffreq, nffreq)
+        
+            !On configure:
+            CALL xios_set_file_attr_hdl(x_file, name="X"//fname,&
+                output_freq=TRIM(ADJUSTL(nffreq)), output_level=flvl, enabled=.TRUE.)
+        
+            IF (xios_is_valid_file("X"//fname)) THEN
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_file: New file: ", "X"//fname
+                  WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
+                ENDIF
+            ELSE
+                WRITE(lunout,*) "wxios_add_file: Error, invalid file: ", "X"//trim(fname)
+                WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
+            END IF
+        ELSE
+            IF (prt_level >= 10) THEN
+              WRITE(lunout,*) "wxios_add_file: File ",trim(fname), " défined using XML."
+            ENDIF
+            ! Ehouarn: add an enable=.true. on top of xml definitions... why???
+            CALL xios_set_file_attr(fname, enabled=.TRUE.)
+        END IF
+    END SUBROUTINE wxios_add_file
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour créer un champ      !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_field(fieldname, fieldgroup, fieldlongname, fieldunit)
+        USE netcdf, only: nf90_fill_real
+
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+        
+        CHARACTER(len=*), INTENT(IN) :: fieldname
+        TYPE(xios_fieldgroup), INTENT(IN) :: fieldgroup
+        CHARACTER(len=*), INTENT(IN) :: fieldlongname
+        CHARACTER(len=*), INTENT(IN) :: fieldunit
+        
+        TYPE(xios_field) :: field
+        CHARACTER(len=10) :: newunit
+        REAL(KIND=8) :: def
+        
+        !La valeur par défaut des champs non définis:
+        def = nf90_fill_real
+        
+        IF (fieldunit .EQ. " ") THEN
+            newunit = "-"
+        ELSE
+            newunit = fieldunit
+        ENDIF
+        
+        !On ajoute le champ:
+        CALL xios_add_field(fieldgroup, field, fieldname)
+        !IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: ",fieldname,fieldgroup, fieldlongname, fieldunit
+        
+        !On rentre ses paramètres:
+        CALL xios_set_field_attr_hdl(field, standard_name=fieldlongname, unit=newunit, default_value=def)
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: Field ",trim(fieldname), "cree:"
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: long_name=",trim(fieldlongname),"; unit=",trim(newunit),";  default_value=",nf90_fill_real
+
+    END SUBROUTINE wxios_add_field
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour déclarer un champ      !!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_field_to_file(fieldname, fdim, fid, fname, fieldlongname, fieldunit, field_level, op, nam_axvert)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*), INTENT(IN) :: fieldname
+        INTEGER, INTENT(IN)          :: fdim, fid
+        CHARACTER(len=*), INTENT(IN) :: fname
+        CHARACTER(len=*), INTENT(IN) :: fieldlongname
+        CHARACTER(len=*), INTENT(IN) :: fieldunit
+        INTEGER, INTENT(IN)          :: field_level
+        CHARACTER(len=*), INTENT(IN) :: op
+        
+        CHARACTER(len=20) :: axis_id ! Ehouarn: dangerous...
+        CHARACTER(len=20), INTENT(IN), OPTIONAL :: nam_axvert
+        CHARACTER(len=100) :: operation
+        TYPE(xios_file) :: f
+        TYPE(xios_field) :: field
+        TYPE(xios_fieldgroup) :: fieldgroup
+        LOGICAL :: bool=.FALSE.
+        INTEGER :: lvl =0
+        
+        
+        ! Ajout Abd pour NMC:
+        IF (fid.LE.6) THEN
+          axis_id="presnivs"
+        ELSE
+          axis_id="plev"
+        ENDIF
+ 
+        IF (PRESENT(nam_axvert)) THEN
+           axis_id=nam_axvert
+           print*,'nam_axvert=',axis_id
+        ENDIF
+        
+        !on prépare le nom de l'opération:
+        operation = reformaop(op)
+        
+        
+        !On selectionne le bon groupe de champs:
+        IF (fdim.EQ.2) THEN
+          CALL xios_get_fieldgroup_handle("fields_2D", fieldgroup)
+        ELSE
+          CALL xios_get_fieldgroup_handle("fields_3D", fieldgroup)
+        ENDIF
+        
+        !On regarde si le champ à déjà été créé ou non:
+        IF (xios_is_valid_field(fieldname) .AND. .NOT. g_field_name == fieldname) THEN
+            !Si ce champ existe via XML (ie, dès le premier passage, ie g_field_name != fieldname) alors rien d'autre à faire
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "exists via XML"
+            g_flag_xml = .TRUE.
+            g_field_name = fieldname
+
+        ELSE IF (.NOT. g_field_name == fieldname) THEN
+            !Si premier pssage et champ indéfini, alors on le créé
+
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "does not exist"
+            
+            !On le créé:
+            CALL wxios_add_field(fieldname,  fieldgroup, fieldlongname, fieldunit)
+            IF (xios_is_valid_field(fieldname)) THEN
+                IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "created"
+            ENDIF
+
+            g_flag_xml = .FALSE.
+            g_field_name = fieldname
+
+        END IF
+
+        IF (.NOT. g_flag_xml) THEN
+            !Champ existe déjà, mais pas XML, alors on l'ajoute
+            !On ajoute le champ:
+            CALL xios_get_file_handle(fname, f)
+            CALL xios_add_fieldtofile(f, field)
+            
+            
+            !L'operation, sa frequence:
+            CALL xios_set_field_attr_hdl(field, field_ref=fieldname, operation=TRIM(ADJUSTL(operation)), freq_op="1ts", prec=4)
+
+            
+            !On rentre ses paramètres:
+            CALL xios_set_field_attr_hdl(field, level=field_level, enabled=.TRUE.)
+            
+            IF (fdim.EQ.2) THEN
+                !Si c'est un champ 2D:
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_field_to_file: 2D Field ", trim(fieldname), " in ", "X"//trim(fname) ," configured with:"
+                  WRITE(lunout,*) "wxios_add_field_to_file: op=", TRIM(ADJUSTL(operation))
+                  WRITE(lunout,*) "wxios_add_field_to_file: freq_op=1ts","; lvl=",field_level
+                ENDIF
+            ELSE
+                !Si 3D :
+                !On ajoute l'axe vertical qui va bien:
+                CALL xios_set_field_attr_hdl(field, axis_ref=TRIM(ADJUSTL(axis_id)))
+                
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_field_to_file: 3D Field",trim(fieldname), " in ", "X"//trim(fname), "configured with:"
+                  WRITE(lunout,*) "wxios_add_field_to_file: freq_op=1ts","; lvl=",field_level
+                  WRITE(lunout,*) "wxios_add_field_to_file: axis=",TRIM(ADJUSTL(axis_id))
+                ENDIF
+            END IF
+        
+        ELSE
+            !Sinon on se contente de l'activer:
+            CALL xios_set_field_attr(fieldname, enabled=.TRUE.)
+            !NB: This will override an enable=.false. set by a user in the xml file;
+            !   then the only way to not output the field is by changing its
+            !   output level
+        ENDIF       
+        
+    END SUBROUTINE wxios_add_field_to_file
+    
+!    SUBROUTINE wxios_update_calendar(ito)
+!        INTEGER, INTENT(IN) :: ito
+!        CALL xios_update_calendar(ito)
+!    END SUBROUTINE wxios_update_calendar
+!    
+!    SUBROUTINE wxios_write_2D(fieldname, fdata)
+!        CHARACTER(len=*), INTENT(IN) :: fieldname
+!        REAL, DIMENSION(:,:), INTENT(IN) :: fdata
+!
+!        CALL xios_send_field(fieldname, fdata)
+!    END SUBROUTINE wxios_write_2D
+    
+!    SUBROUTINE wxios_write_3D(fieldname, fdata)
+!        CHARACTER(len=*), INTENT(IN) :: fieldname
+!        REAL, DIMENSION(:,:,:), INTENT(IN) :: fdata
+!        
+!        CALL xios_send_field(fieldname, fdata)
+!    END SUBROUTINE wxios_write_3D
+    
+    SUBROUTINE wxios_closedef()
+        CALL xios_close_context_definition()
+!        CALL xios_update_calendar(0)
+    END SUBROUTINE wxios_closedef
+    
+    SUBROUTINE wxios_close()
+        CALL xios_context_finalize()
+         CALL xios_finalize()
+     END SUBROUTINE wxios_close
+END MODULE wxios
+#endif
Index: LMDZ5/branches/testing/libf/misc/xercnt.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xercnt.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xercnt.F	(revision 2298)
@@ -0,0 +1,62 @@
+*DECK XERCNT
+      SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  XERCNT
+C***SUBSIDIARY
+C***PURPOSE  Allow user control over handling of errors.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERCNT-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        Allows user control over handling of individual errors.
+C        Just after each message is recorded, but before it is
+C        processed any further (i.e., before it is printed or
+C        a decision to abort is made), a call is made to XERCNT.
+C        If the user has provided his own version of XERCNT, he
+C        can then override the value of KONTROL used in processing
+C        this message by redefining its value.
+C        KONTRL may be set to any value from -2 to 2.
+C        The meanings for KONTRL are the same as in XSETF, except
+C        that the value of KONTRL changes only for this message.
+C        If KONTRL is set to a value outside the range from -2 to 2,
+C        it will be moved back into that range.
+C
+C     Description of Parameters
+C
+C      --Input--
+C        LIBRAR - the library that the routine is in.
+C        SUBROU - the subroutine that XERMSG is being called from
+C        MESSG  - the first 20 characters of the error message.
+C        NERR   - same as in the call to XERMSG.
+C        LEVEL  - same as in the call to XERMSG.
+C        KONTRL - the current value of the control flag as set
+C                 by a call to XSETF.
+C
+C      --Output--
+C        KONTRL - the new value of KONTRL.  If KONTRL is not
+C                 defined, it will remain at its original value.
+C                 This changed value of control affects only
+C                 the current occurrence of the current message.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900206  Routine changed from user-callable to subsidiary.  (WRB)
+C   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
+C           names, changed routine name from XERCTL to XERCNT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERCNT
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      INTEGER NERR, LEVEL, KONTRL
+C***FIRST EXECUTABLE STATEMENT  XERCNT
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/xerhlt.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xerhlt.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xerhlt.F	(revision 2298)
@@ -0,0 +1,39 @@
+*DECK XERHLT
+      SUBROUTINE XERHLT (MESSG)
+C***BEGIN PROLOGUE  XERHLT
+C***SUBSIDIARY
+C***PURPOSE  Abort program execution and print error message.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERHLT-A)
+C***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        ***Note*** machine dependent routine
+C        XERHLT aborts the execution of the program.
+C        The error message causing the abort is given in the calling
+C        sequence, in case one needs it for printing on a dayfile,
+C        for example.
+C
+C     Description of Parameters
+C        MESSG is as in XERMSG.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900206  Routine changed from user-callable to subsidiary.  (WRB)
+C   900510  Changed calling sequence to delete length of character
+C           and changed routine name from XERABT to XERHLT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERHLT
+      CHARACTER*(*) MESSG
+C***FIRST EXECUTABLE STATEMENT  XERHLT
+      STOP
+      END
Index: LMDZ5/branches/testing/libf/misc/xermsg.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xermsg.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xermsg.F	(revision 2298)
@@ -0,0 +1,368 @@
+*DECK XERMSG
+      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  XERMSG
+C***PURPOSE  Process error messages for SLATEC and other libraries.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERMSG-A)
+C***KEYWORDS  ERROR MESSAGE, XERROR
+C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+C***DESCRIPTION
+C
+C   XERMSG processes a diagnostic message in a manner determined by the
+C   value of LEVEL and the current value of the library error control
+C   flag, KONTRL.  See subroutine XSETF for details.
+C
+C    LIBRAR   A character constant (or character variable) with the name
+C             of the library.  This will be 'SLATEC' for the SLATEC
+C             Common Math Library.  The error handling package is
+C             general enough to be used by many libraries
+C             simultaneously, so it is desirable for the routine that
+C             detects and reports an error to identify the library name
+C             as well as the routine name.
+C
+C    SUBROU   A character constant (or character variable) with the name
+C             of the routine that detected the error.  Usually it is the
+C             name of the routine that is calling XERMSG.  There are
+C             some instances where a user callable library routine calls
+C             lower level subsidiary routines where the error is
+C             detected.  In such cases it may be more informative to
+C             supply the name of the routine the user called rather than
+C             the name of the subsidiary routine that detected the
+C             error.
+C
+C    MESSG    A character constant (or character variable) with the text
+C             of the error or warning message.  In the example below,
+C             the message is a character constant that contains a
+C             generic message.
+C
+C                   CALL XERMSG ('SLATEC', 'MMPY',
+C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
+C                  *3, 1)
+C
+C             It is possible (and is sometimes desirable) to generate a
+C             specific message--e.g., one that contains actual numeric
+C             values.  Specific numeric values can be converted into
+C             character strings using formatted WRITE statements into
+C             character variables.  This is called standard Fortran
+C             internal file I/O and is exemplified in the first three
+C             lines of the following example.  You can also catenate
+C             substrings of characters to construct the error message.
+C             Here is an example showing the use of both writing to
+C             an internal file and catenating character strings.
+C
+C                   CHARACTER*5 CHARN, CHARL
+C                   WRITE (CHARN,10) N
+C                   WRITE (CHARL,10) LDA
+C                10 FORMAT(I5)
+C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
+C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
+C                  *   CHARL, 3, 1)
+C
+C             There are two subtleties worth mentioning.  One is that
+C             the // for character catenation is used to construct the
+C             error message so that no single character constant is
+C             continued to the next line.  This avoids confusion as to
+C             whether there are trailing blanks at the end of the line.
+C             The second is that by catenating the parts of the message
+C             as an actual argument rather than encoding the entire
+C             message into one large character variable, we avoid
+C             having to know how long the message will be in order to
+C             declare an adequate length for that large character
+C             variable.  XERMSG calls XERPRN to print the message using
+C             multiple lines if necessary.  If the message is very long,
+C             XERPRN will break it into pieces of 72 characters (as
+C             requested by XERMSG) for printing on multiple lines.
+C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
+C             so that the total line length could be 76 characters.
+C             Note also that XERPRN scans the error message backwards
+C             to ignore trailing blanks.  Another feature is that
+C             the substring '$$' is treated as a new line sentinel
+C             by XERPRN.  If you want to construct a multiline
+C             message without having to count out multiples of 72
+C             characters, just use '$$' as a separator.  '$$'
+C             obviously must occur within 72 characters of the
+C             start of each line to have its intended effect since
+C             XERPRN is asked to wrap around at 72 characters in
+C             addition to looking for '$$'.
+C
+C    NERR     An integer value that is chosen by the library routine's
+C             author.  It must be in the range -99 to 999 (three
+C             printable digits).  Each distinct error should have its
+C             own error number.  These error numbers should be described
+C             in the machine readable documentation for the routine.
+C             The error numbers need be unique only within each routine,
+C             so it is reasonable for each routine to start enumerating
+C             errors from 1 and proceeding to the next integer.
+C
+C    LEVEL    An integer value in the range 0 to 2 that indicates the
+C             level (severity) of the error.  Their meanings are
+C
+C            -1  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.  An attempt is made to only print this
+C                message once.
+C
+C             0  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.
+C
+C             1  A recoverable error.  This is used even if the error is
+C                so serious that the routine cannot return any useful
+C                answer.  If the user has told the error package to
+C                return after recoverable errors, then XERMSG will
+C                return to the Library routine which can then return to
+C                the user's routine.  The user may also permit the error
+C                package to terminate the program upon encountering a
+C                recoverable error.
+C
+C             2  A fatal error.  XERMSG will not return to its caller
+C                after it receives a fatal error.  This level should
+C                hardly ever be used; it is much better to allow the
+C                user a chance to recover.  An example of one of the few
+C                cases in which it is permissible to declare a level 2
+C                error is a reverse communication Library routine that
+C                is likely to be called repeatedly until it integrates
+C                across some interval.  If there is a serious error in
+C                the input such that another step cannot be taken and
+C                the Library routine is called again without the input
+C                error having been corrected by the caller, the Library
+C                routine will probably be called forever with improper
+C                input.  In this case, it is reasonable to declare the
+C                error to be fatal.
+C
+C    Each of the arguments to XERMSG is input; none will be modified by
+C    XERMSG.  A routine may make multiple calls to XERMSG with warning
+C    level messages; however, after a call to XERMSG with a recoverable
+C    error, the routine should return to the user.  Do not try to call
+C    XERMSG with a second recoverable error after the first recoverable
+C    error because the error package saves the error number.  The user
+C    can retrieve this error number by calling another entry point in
+C    the error handling package and then clear the error number when
+C    recovering from the error.  Calling XERMSG in succession causes the
+C    old error number to be overwritten by the latest error number.
+C    This is considered harmless for error numbers associated with
+C    warning messages but must not be done for error numbers of serious
+C    errors.  After a call to XERMSG with a recoverable error, the user
+C    must be given a chance to call NUMXER or XERCLR to retrieve or
+C    clear the error number.
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
+C***REVISION HISTORY  (YYMMDD)
+C   880101  DATE WRITTEN
+C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
+C           THERE ARE TWO BASIC CHANGES.
+C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
+C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
+C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
+C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
+C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
+C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
+C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
+C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
+C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
+C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
+C               OF LOWER CASE.
+C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
+C           THE PRINCIPAL CHANGES ARE
+C           1.  CLARIFY COMMENTS IN THE PROLOGUES
+C           2.  RENAME XRPRNT TO XERPRN
+C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
+C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
+C               CHARACTER FOR NEW RECORDS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+C           CLEAN UP THE CODING.
+C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
+C           PREFIX.
+C   891013  REVISED TO CORRECT COMMENTS.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
+C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
+C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
+C           XERCTL to XERCNT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERMSG
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      CHARACTER*8 XLIBR, XSUBR
+      CHARACTER*72  TEMP
+      CHARACTER*20  LFIRST
+      INTEGER NERR, LEVEL, LKNTRL
+      INTEGER J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
+      INTEGER MKNTRL, LTEMP
+C***FIRST EXECUTABLE STATEMENT  XERMSG
+      LKNTRL = J4SAVE (2, 0, .FALSE.)
+      MAXMES = J4SAVE (4, 0, .FALSE.)
+C
+C       LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
+C       MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
+C          SHOULD BE PRINTED.
+C
+C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
+C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
+C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
+C
+      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
+     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
+         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
+     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
+     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
+         CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
+         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
+         RETURN
+      ENDIF
+C
+C       RECORD THE MESSAGE.
+C
+      I = J4SAVE (1, NERR, .TRUE.)
+      CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
+C
+C       HANDLE PRINT-ONCE WARNING MESSAGES.
+C
+      IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN
+C
+C       ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
+C
+      XLIBR  = LIBRAR
+      XSUBR  = SUBROU
+      LFIRST = MESSG
+      LERR   = NERR
+      LLEVEL = LEVEL
+      CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
+C
+      LKNTRL = MAX(-2, MIN(2,LKNTRL))
+      MKNTRL = ABS(LKNTRL)
+C
+C       SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
+C       ZERO AND THE ERROR IS NOT FATAL.
+C
+      IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30
+      IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30
+      IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30
+      IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30
+C
+C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
+C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
+C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
+C       IS NOT ZERO.
+C
+      IF (LKNTRL .NE. 0) THEN
+         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
+         I = MIN(LEN(SUBROU), 16)
+         TEMP(22:21+I) = SUBROU(1:I)
+         TEMP(22+I:33+I) = ' IN LIBRARY '
+         LTEMP = 33 + I
+         I = MIN(LEN(LIBRAR), 16)
+         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
+         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
+         LTEMP = LTEMP + I + 1
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
+C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
+C       FROM EACH OF THE FOLLOWING THREE OPTIONS.
+C       1.  LEVEL OF THE MESSAGE
+C              'INFORMATIVE MESSAGE'
+C              'POTENTIALLY RECOVERABLE ERROR'
+C              'FATAL ERROR'
+C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
+C              'PROG CONTINUES'
+C              'PROG ABORTED'
+C       3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
+C           MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
+C           WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
+C              'TRACEBACK REQUESTED'
+C              'TRACEBACK NOT REQUESTED'
+C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
+C       EXCEED 74 CHARACTERS.
+C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
+C
+      IF (LKNTRL .GT. 0) THEN
+C
+C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
+C
+         IF (LEVEL .LE. 0) THEN
+            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
+            LTEMP = 20
+         ELSEIF (LEVEL .EQ. 1) THEN
+            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
+            LTEMP = 30
+         ELSE
+            TEMP(1:12) = 'FATAL ERROR,'
+            LTEMP = 12
+         ENDIF
+C
+C       THEN WHETHER THE PROGRAM WILL CONTINUE.
+C
+         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
+     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
+            TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
+            LTEMP = LTEMP + 14
+         ELSE
+            TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
+            LTEMP = LTEMP + 16
+         ENDIF
+C
+C       FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
+C
+         IF (LKNTRL .GT. 0) THEN
+            TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
+            LTEMP = LTEMP + 20
+         ELSE
+            TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
+            LTEMP = LTEMP + 24
+         ENDIF
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       NOW SEND OUT THE MESSAGE.
+C
+      CALL XERPRN (' *  ', -1, MESSG, 72)
+C
+C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
+C          TRACEBACK.
+C
+      IF (LKNTRL .GT. 0) THEN
+         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
+         DO 10 I=16,22
+            IF (TEMP(I:I) .NE. ' ') GO TO 20
+   10    CONTINUE
+C
+   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
+         CALL FDUMP
+      ENDIF
+C
+C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
+C
+      IF (LKNTRL .NE. 0) THEN
+         CALL XERPRN (' *  ', -1, ' ', 72)
+         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
+         CALL XERPRN ('    ',  0, ' ', 72)
+      ENDIF
+C
+C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
+C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
+C
+   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
+C
+C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
+C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
+C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
+C
+      IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN
+         IF (LEVEL .EQ. 1) THEN
+            CALL XERPRN
+     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
+         ELSE
+            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
+         ENDIF
+         CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
+         CALL XERHLT (' ')
+      ELSE
+         CALL XERHLT (MESSG)
+      ENDIF
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/xerprn.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xerprn.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xerprn.F	(revision 2298)
@@ -0,0 +1,231 @@
+*DECK XERPRN
+      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  XERPRN
+C***SUBSIDIARY
+C***PURPOSE  Print error messages processed by XERMSG.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERPRN-A)
+C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
+C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+C***DESCRIPTION
+C
+C This routine sends one or more lines to each of the (up to five)
+C logical units to which error messages are to be sent.  This routine
+C is called several times by XERMSG, sometimes with a single line to
+C print and sometimes with a (potentially very long) message that may
+C wrap around into multiple lines.
+C
+C PREFIX  Input argument of type CHARACTER.  This argument contains
+C         characters to be put at the beginning of each line before
+C         the body of the message.  No more than 16 characters of
+C         PREFIX will be used.
+C
+C NPREF   Input argument of type INTEGER.  This argument is the number
+C         of characters to use from PREFIX.  If it is negative, the
+C         intrinsic function LEN is used to determine its length.  If
+C         it is zero, PREFIX is not used.  If it exceeds 16 or if
+C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
+C         used.  If NPREF is positive and the length of PREFIX is less
+C         than NPREF, a copy of PREFIX extended with blanks to length
+C         NPREF will be used.
+C
+C MESSG   Input argument of type CHARACTER.  This is the text of a
+C         message to be printed.  If it is a long message, it will be
+C         broken into pieces for printing on multiple lines.  Each line
+C         will start with the appropriate prefix and be followed by a
+C         piece of the message.  NWRAP is the number of characters per
+C         piece; that is, after each NWRAP characters, we break and
+C         start a new line.  In addition the characters '$$' embedded
+C         in MESSG are a sentinel for a new line.  The counting of
+C         characters up to NWRAP starts over for each new line.  The
+C         value of NWRAP typically used by XERMSG is 72 since many
+C         older error messages in the SLATEC Library are laid out to
+C         rely on wrap-around every 72 characters.
+C
+C NWRAP   Input argument of type INTEGER.  This gives the maximum size
+C         piece into which to break MESSG for printing on multiple
+C         lines.  An embedded '$$' ends a line, and the count restarts
+C         at the following character.  If a line break does not occur
+C         on a blank (it would split a word) that word is moved to the
+C         next line.  Values of NWRAP less than 16 will be treated as
+C         16.  Values of NWRAP greater than 132 will be treated as 132.
+C         The actual line length will be NPREF + NWRAP after NPREF has
+C         been adjusted to fall between 0 and 16 and NWRAP has been
+C         adjusted to fall between 16 and 132.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  I1MACH, XGETUA
+C***REVISION HISTORY  (YYMMDD)
+C   880621  DATE WRITTEN
+C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
+C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
+C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
+C           SLASH CHARACTER IN FORMAT STATEMENTS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
+C           LINES TO BE PRINTED.
+C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
+C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
+C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Added code to break messages between words.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERPRN
+      CHARACTER*(*) PREFIX, MESSG
+      INTEGER NPREF, NWRAP
+      CHARACTER*148 CBUFF
+      INTEGER IU(5), NUNIT
+      CHARACTER*2 NEWLIN
+      PARAMETER (NEWLIN = '$$')
+      INTEGER N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC
+      INTEGER LPIECE, IDELTA
+C***FIRST EXECUTABLE STATEMENT  XERPRN
+      CALL XGETUA(IU,NUNIT)
+C
+C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
+C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
+C       ERROR MESSAGE UNIT.
+C
+      N = I1MACH(4)
+      DO 10 I=1,NUNIT
+         IF (IU(I) .EQ. 0) IU(I) = N
+   10 CONTINUE
+C
+C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
+C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
+C       THE REST OF THIS ROUTINE.
+C
+      IF ( NPREF .LT. 0 ) THEN
+         LPREF = LEN(PREFIX)
+      ELSE
+         LPREF = NPREF
+      ENDIF
+      LPREF = MIN(16, LPREF)
+      IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
+C
+C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
+C       TIME FROM MESSG TO PRINT ON ONE LINE.
+C
+      LWRAP = MAX(16, MIN(132, NWRAP))
+C
+C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
+C
+      LENMSG = LEN(MESSG)
+      N = LENMSG
+      DO 20 I=1,N
+         IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
+         LENMSG = LENMSG - 1
+   20 CONTINUE
+   30 CONTINUE
+C
+C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
+C
+      IF (LENMSG .EQ. 0) THEN
+         CBUFF(LPREF+1:LPREF+1) = ' '
+         DO 40 I=1,NUNIT
+            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
+   40    CONTINUE
+         RETURN
+      ENDIF
+C
+C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
+C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
+C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
+C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
+C
+C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
+C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
+C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
+C       OF THE SECOND ARGUMENT.
+C
+C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
+C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
+C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
+C       POSITION NEXTC.
+C
+C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
+C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
+C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
+C                       WHICHEVER IS LESS.
+C
+C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
+C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
+C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
+C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
+C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
+C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
+C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
+C                       SHOULD BE INCREMENTED BY 2.
+C
+C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
+C
+C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
+C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
+C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
+C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
+C                       AT THE END OF A LINE.
+C
+      NEXTC = 1
+   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
+      IF (LPIECE .EQ. 0) THEN
+C
+C       THERE WAS NO NEW LINE SENTINEL FOUND.
+C
+         IDELTA = 0
+         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
+         IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
+            DO 52 I=LPIECE+1,2,-1
+               IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+                  LPIECE = I-1
+                  IDELTA = 1
+                  GOTO 54
+               ENDIF
+   52       CONTINUE
+         ENDIF
+   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSEIF (LPIECE .EQ. 1) THEN
+C
+C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
+C       DON'T PRINT A BLANK LINE.
+C
+         NEXTC = NEXTC + 2
+         GO TO 50
+      ELSEIF (LPIECE .GT. LWRAP+1) THEN
+C
+C       LPIECE SHOULD BE SET DOWN TO LWRAP.
+C
+         IDELTA = 0
+         LPIECE = LWRAP
+         DO 56 I=LPIECE+1,2,-1
+            IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+               LPIECE = I-1
+               IDELTA = 1
+               GOTO 58
+            ENDIF
+   56    CONTINUE
+   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSE
+C
+C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
+C       WE SHOULD DECREMENT LPIECE BY ONE.
+C
+         LPIECE = LPIECE - 1
+         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC  = NEXTC + LPIECE + 2
+      ENDIF
+C
+C       PRINT
+C
+      DO 60 I=1,NUNIT
+         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
+   60 CONTINUE
+C
+      IF (NEXTC .LE. LENMSG) GO TO 50
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/misc/xersve.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xersve.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xersve.F	(revision 2298)
@@ -0,0 +1,159 @@
+*DECK XERSVE
+      SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
+     +   ICOUNT)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  XERSVE
+C***SUBSIDIARY
+C***PURPOSE  Record that an error has occurred.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3
+C***TYPE      ALL (XERSVE-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C *Usage:
+C
+C        INTEGER  KFLAG, NERR, LEVEL, ICOUNT
+C        CHARACTER * (len) LIBRAR, SUBROU, MESSG
+C
+C        CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
+C
+C *Arguments:
+C
+C        LIBRAR :IN    is the library that the message is from.
+C        SUBROU :IN    is the subroutine that the message is from.
+C        MESSG  :IN    is the message to be saved.
+C        KFLAG  :IN    indicates the action to be performed.
+C                      when KFLAG > 0, the message in MESSG is saved.
+C                      when KFLAG=0 the tables will be dumped and
+C                      cleared.
+C                      when KFLAG < 0, the tables will be dumped and
+C                      not cleared.
+C        NERR   :IN    is the error number.
+C        LEVEL  :IN    is the error severity.
+C        ICOUNT :OUT   the number of times this message has been seen,
+C                      or zero if the table has overflowed and does not
+C                      contain this message specifically.  When KFLAG=0,
+C                      ICOUNT will not be altered.
+C
+C *Description:
+C
+C   Record that this error occurred and possibly dump and clear the
+C   tables.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  I1MACH, XGETUA
+C***REVISION HISTORY  (YYMMDD)
+C   800319  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900413  Routine modified to remove reference to KFLAG.  (WRB)
+C   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
+C           sequence, use IF-THEN-ELSE, make number of saved entries
+C           easily changeable, changed routine name from XERSAV to
+C           XERSVE.  (RWC)
+C   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERSVE
+      INTEGER,PARAMETER :: LENTAB=10
+      INTEGER LUN(5)
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      CHARACTER*8  LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
+      CHARACTER*20 MESTAB(LENTAB), MES
+      DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
+      SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
+      DATA KOUNTX/0/, NMSG/0/
+      INTEGER NERR,LEVEL,KONTRL
+      INTEGER NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
+      INTEGER KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
+C***FIRST EXECUTABLE STATEMENT  XERSVE
+C
+      IF (KFLAG.LE.0) THEN
+C
+C        Dump the table.
+C
+         IF (NMSG.EQ.0) RETURN
+C
+C        Print to each unit.
+C
+         CALL XGETUA (LUN, NUNIT)
+         DO 20 KUNIT = 1,NUNIT
+            IUNIT = LUN(KUNIT)
+            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
+C
+C           Print the table header.
+C
+            WRITE (IUNIT,9000)
+C
+C           Print body of table.
+C
+            DO 10 I = 1,NMSG
+               WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
+     *            NERTAB(I),LEVTAB(I),KOUNT(I)
+   10       CONTINUE
+C
+C           Print number of other errors.
+C
+            IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX
+            WRITE (IUNIT,9030)
+   20    CONTINUE
+C
+C        Clear the error tables.
+C
+         IF (KFLAG.EQ.0) THEN
+            NMSG = 0
+            KOUNTX = 0
+         ENDIF
+      ELSE
+C
+C        PROCESS A MESSAGE...
+C        SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
+C        OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
+C
+         LIB = LIBRAR
+         SUB = SUBROU
+         MES = MESSG
+         DO 30 I = 1,NMSG
+            IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND.
+     *         MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND.
+     *         LEVEL.EQ.LEVTAB(I)) THEN
+                  KOUNT(I) = KOUNT(I) + 1
+                  ICOUNT = KOUNT(I)
+                  RETURN
+            ENDIF
+   30    CONTINUE
+C
+         IF (NMSG.LT.LENTAB) THEN
+C
+C           Empty slot found for new message.
+C
+            NMSG = NMSG + 1
+            LIBTAB(I) = LIB
+            SUBTAB(I) = SUB
+            MESTAB(I) = MES
+            NERTAB(I) = NERR
+            LEVTAB(I) = LEVEL
+            KOUNT (I) = 1
+            ICOUNT    = 1
+         ELSE
+C
+C           Table is full.
+C
+            KOUNTX = KOUNTX+1
+            ICOUNT = 0
+         ENDIF
+      ENDIF
+      RETURN
+C
+C     Formats.
+C
+ 9000 FORMAT ('0          ERROR MESSAGE SUMMARY' /
+     +   ' LIBRARY    SUBROUTINE MESSAGE START             NERR',
+     +   '     LEVEL     COUNT')
+ 9010 FORMAT (1X,A,3X,A,3X,A,3I10)
+ 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
+ 9030 FORMAT (1X)
+      END
Index: LMDZ5/branches/testing/libf/misc/xgetua.F
===================================================================
--- LMDZ5/branches/testing/libf/misc/xgetua.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/misc/xgetua.F	(revision 2298)
@@ -0,0 +1,53 @@
+*DECK XGETUA
+      SUBROUTINE XGETUA (IUNITA, N)
+      IMPLICIT NONE
+C***BEGIN PROLOGUE  XGETUA
+C***PURPOSE  Return unit number(s) to which error messages are being
+C            sent.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XGETUA-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        XGETUA may be called to determine the unit number or numbers
+C        to which error messages are being sent.
+C        These unit numbers may have been set by a call to XSETUN,
+C        or a call to XSETUA, or may be a default value.
+C
+C     Description of Parameters
+C      --Output--
+C        IUNIT - an array of one to five unit numbers, depending
+C                on the value of N.  A value of zero refers to the
+C                default unit, as defined by the I1MACH machine
+C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
+C                defined by XGETUA.  The values of IUNIT(N+1),...,
+C                IUNIT(5) are not defined (for N .LT. 5) or altered
+C                in any way by XGETUA.
+C        N     - the number of units to which copies of the
+C                error messages are being sent.  N will be in the
+C                range from 1 to 5.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  J4SAVE
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XGETUA
+      DIMENSION IUNITA(5)
+      INTEGER IUNITA, N, J4SAVE, INDEX, I
+C***FIRST EXECUTABLE STATEMENT  XGETUA
+      N = J4SAVE(5,0,.FALSE.)
+      DO 30 I=1,N
+         INDEX = I+4
+         IF (I.EQ.1) INDEX = 3
+         IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
+   30 CONTINUE
+      RETURN
+      END
Index: LMDZ5/branches/testing/libf/phydev/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/iniphysiq.F90	(revision 2274)
+++ 	(revision )
@@ -1,146 +1,0 @@
-!
-! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
-!
-SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
-                     rlatu,rlonv,aire,cu,cv,                             &
-                     prad,pg,pr,pcpp,iflag_phys)
-  USE dimphy, ONLY: klev ! number of atmospheric levels
-  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
-                                        ! (on full grid)
-  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 comgeomphy, ONLY: initcomgeomphy, &
-                        airephy, & ! physics grid area (m2)
-                        cuphy, & ! cu coeff. (u_covariant = cu * u)
-                        cvphy, & ! cv coeff. (v_covariant = cv * v)
-                        rlond, & ! longitudes
-                        rlatd ! latitudes
-  USE comcstphy, ONLY: rradius, & ! planet radius (m)
-                       rr, & ! recuced gas constant: R/molar mass of atm
-                       rg, & ! gravity
-                       rcpp  ! specific heat of the atmosphere
-  USE phyaqua_mod, ONLY: iniaqua
-  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
-  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
-  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes 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
-  CHARACTER (LEN=20) :: modname='iniphysiq'
-  CHARACTER (LEN=80) :: abort_message
-  REAL :: total_area_phy, total_area_dyn
-
-
-  ! global array, on full physics grid:
-  REAL,ALLOCATABLE :: latfi(:)
-  REAL,ALLOCATABLE :: lonfi(:)
-  REAL,ALLOCATABLE :: cufi(:)
-  REAL,ALLOCATABLE :: cvfi(:)
-  REAL,ALLOCATABLE :: airefi(:)
-
-  IF (nlayer.NE.klev) THEN
-    WRITE(lunout,*) 'STOP in ',trim(modname)
-    WRITE(lunout,*) 'Problem with dimensions :'
-    WRITE(lunout,*) 'nlayer     = ',nlayer
-    WRITE(lunout,*) 'klev   = ',klev
-    abort_message = ''
-    CALL abort_gcm (modname,abort_message,1)
-  ENDIF
-
-  !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/))
-  
-  ! Generate global arrays on full physics grid
-  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
-  ALLOCATE(airefi(klon_glo))
-
-    ! North pole
-    latfi(1)=rlatu(1)
-    lonfi(1)=0.
-    cufi(1) = cu(1)
-    cvfi(1) = cv(1)
-    DO j=2,jjm
-      DO i=1,iim
-        latfi((j-2)*iim+1+i)= rlatu(j)
-        lonfi((j-2)*iim+1+i)= rlonv(i)
-        cufi((j-2)*iim+1+i) = cu((j-1)*iim+1+i)
-        cvfi((j-2)*iim+1+i) = cv((j-1)*iim+1+i)
-      ENDDO
-    ENDDO
-    ! South pole
-    latfi(klon_glo)= rlatu(jjm+1)
-    lonfi(klon_glo)= 0.
-    cufi(klon_glo) = cu((iim+1)*jjm+1)
-    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
-
-    ! build airefi(), mesh area on physics grid
-    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
-    ! Poles are single points on physics grid
-    airefi(1)=sum(aire(1:iim,1))
-    airefi(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(1:klon_glo))
-    IF (total_area_dyn/=total_area_phy) THEN
-      WRITE (lunout, *) 'iniphysiq: 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
-
-!$OMP PARALLEL 
-  ! Now generate local lon/lat/cu/cv/area arrays
-  CALL initcomgeomphy
-
-  offset = klon_mpi_begin - 1
-  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
-  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
-  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
-  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
-  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
-
-  ! copy some fundamental parameters to physics
-  rradius=prad
-  rg=pg
-  rr=pr
-  rcpp=pcpp
-
-!$OMP END PARALLEL
-
-  ! Additional initializations for aquaplanets 
-!$OMP PARALLEL
-  IF (iflag_phys>=100) THEN
-    CALL iniaqua(klon_omp,rlatd,rlond,iflag_phys)
-  ENDIF
-!$OMP END PARALLEL
-
-END SUBROUTINE iniphysiq
Index: LMDZ5/branches/testing/libf/phydev/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_grid_phy_lmdz.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_grid_phy_lmdz.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_mpi_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_mpi_data.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_mpi_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_mpi_transfert.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_omp_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_omp_data.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_omp_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_omp_transfert.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_para.F90
Index: LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phydev/mod_phys_lmdz_transfert_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_transfert_para.F90
Index: LMDZ5/branches/testing/libf/phylmd/1DUTILS.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1DUTILS.h	(revision 2274)
+++ 	(revision )
@@ -1,4448 +1,0 @@
-#include "../dyn3d/conf_gcm.F90"
-#include "../dyn3d_common/q_sat.F"
-
-!
-! $Id: conf_unicol.F 1279 2010-08-04 17:20:56Z lahellec $
-!
-!
-!
-      SUBROUTINE conf_unicol
-!
-#ifdef CPP_IOIPSL
-      use IOIPSL
-#else
-! if not using IOIPSL, we still need to use (a local version of) getin
-      use ioipsl_getincom
-#endif
-      IMPLICIT NONE
-!-----------------------------------------------------------------------
-!     Auteurs :   A. Lahellec  .
-!
-!   Declarations :
-!   --------------
-
-#include "compar1d.h"
-#include "flux_arp.h"
-#include "tsoilnudge.h"
-#include "fcg_gcssold.h"
-#include "fcg_racmo.h"
-#include "iniprint.h"
-!
-!
-!   local:
-!   ------
-
-!      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
-      
-!
-!  -------------------------------------------------------------------
-!
-!      .........    Initilisation parametres du lmdz1D      ..........
-!
-!---------------------------------------------------------------------
-!   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(lunout,FILE='lmdz.out')
-      ENDIF
-
-!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('prt_level',prt_level)
-
-!-----------------------------------------------------------------------
-!  Parametres de controle du run:
-!-----------------------------------------------------------------------
-
-!Config  Key  = restart
-!Config  Desc = on repart des startphy et start1dyn
-!Config  Def  = false
-!Config  Help = les fichiers restart doivent etre renomme en start
-       restart =.false.
-       CALL getin('restart',restart)
-
-!Config  Key  = forcing_type
-!Config  Desc = defines the way the SCM is forced:
-!Config  Def  = 0
-!!Config  Help = 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)
-!         = 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)
-!         = 2 ==> forcing_toga = .true.
-!             initial profiles from TOGA-COARE IFA files 
-!             LS convergence and SST imposed from TOGA-COARE IFA files 
-!         = 3 ==> forcing_GCM2SCM = .true.
-!             initial profiles from the GCM output
-!             LS convergence imposed from the GCM output
-!         = 4 ==> forcing_twpi = .true.
-!             initial profiles from TWPICE nc files 
-!             LS convergence and SST imposed from TWPICE nc files 
-!         = 5 ==> forcing_rico = .true.
-!             initial profiles from RICO idealized
-!             LS convergence imposed from  RICO (cst) 
-!         = 6 ==> forcing_amma = .true.
-!         = 10 ==> forcing_case = .true.
-!             initial profiles from case.nc file 
-!         = 40 ==> forcing_GCSSold = .true.
-!             initial profile from GCSS file
-!             LS convergence imposed from GCSS file
-!         = 50 ==> forcing_fire = .true.
-!         = 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
-!         = 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
-!         = 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
-!
-       forcing_type = 0
-       CALL getin('forcing_type',forcing_type)
-         imp_fcg_gcssold   = .false.
-         ts_fcg_gcssold    = .false.  
-         Tp_fcg_gcssold    = .false.  
-         Tp_ini_gcssold    = .false.  
-         xTurb_fcg_gcssold = .false. 
-        IF (forcing_type .eq.40) THEN
-          CALL getin('imp_fcg',imp_fcg_gcssold)
-          CALL getin('ts_fcg',ts_fcg_gcssold)
-          CALL getin('tp_fcg',Tp_fcg_gcssold)
-          CALL getin('tp_ini',Tp_ini_gcssold)
-          CALL getin('turb_fcg',xTurb_fcg_gcssold)
-        ENDIF
-
-!Paramètres de forçage
-!Config  Key  = tend_t
-!Config  Desc = forcage ou non par advection de T
-!Config  Def  = false
-!Config  Help = forcage ou non par advection de T
-       tend_t =0
-       CALL getin('tend_t',tend_t)
-
-!Config  Key  = tend_q
-!Config  Desc = forcage ou non par advection de q
-!Config  Def  = false
-!Config  Help = forcage ou non par advection de q
-       tend_q =0
-       CALL getin('tend_q',tend_q)
-
-!Config  Key  = tend_u
-!Config  Desc = forcage ou non par advection de u
-!Config  Def  = false
-!Config  Help = forcage ou non par advection de u
-       tend_u =0
-       CALL getin('tend_u',tend_u)
-
-!Config  Key  = tend_v
-!Config  Desc = forcage ou non par advection de v
-!Config  Def  = false
-!Config  Help = forcage ou non par advection de v
-       tend_v =0
-       CALL getin('tend_v',tend_v)
-
-!Config  Key  = tend_w
-!Config  Desc = forcage ou non par vitesse verticale
-!Config  Def  = false
-!Config  Help = forcage ou non par vitesse verticale
-       tend_w =0
-       CALL getin('tend_w',tend_w)
-
-!Config  Key  = tend_rayo
-!Config  Desc = forcage ou non par dtrad
-!Config  Def  = false
-!Config  Help = forcage ou non par dtrad
-       tend_rayo =0
-       CALL getin('tend_rayo',tend_rayo)
-
-
-!Config  Key  = nudge_t
-!Config  Desc = constante de nudging de T
-!Config  Def  = false
-!Config  Help = constante de nudging de T
-       nudge_t =0.
-       CALL getin('nudge_t',nudge_t)
-
-!Config  Key  = nudge_q
-!Config  Desc = constante de nudging de q
-!Config  Def  = false
-!Config  Help = constante de nudging de q
-       nudge_q =0.
-       CALL getin('nudge_q',nudge_q)
-
-!Config  Key  = nudge_u
-!Config  Desc = constante de nudging de u
-!Config  Def  = false
-!Config  Help = constante de nudging de u
-       nudge_u =0.
-       CALL getin('nudge_u',nudge_u)
-
-!Config  Key  = nudge_v
-!Config  Desc = constante de nudging de v
-!Config  Def  = false
-!Config  Help = constante de nudging de v
-       nudge_v =0.
-       CALL getin('nudge_v',nudge_v)
-
-!Config  Key  = nudge_w
-!Config  Desc = constante de nudging de w
-!Config  Def  = false
-!Config  Help = constante de nudging de w
-       nudge_w =0.
-       CALL getin('nudge_w',nudge_w)
-
-
-!Config  Key  = iflag_nudge
-!Config  Desc = atmospheric nudging ttype (decimal code)
-!Config  Def  = 0
-!Config  Help = 0 ==> no nudging
-!  If digit number n of iflag_nudge is set, then nudging of type n is on
-!  If digit number n of iflag_nudge is not set, then nudging of type n is off
-!   (digits are numbered from the right)
-       iflag_nudge = 0
-       CALL getin('iflag_nudge',iflag_nudge)
-
-!Config  Key  = ok_flux_surf
-!Config  Desc = forcage ou non par les flux de surface
-!Config  Def  = false
-!Config  Help = forcage ou non par les flux de surface
-       ok_flux_surf =.false.
-       CALL getin('ok_flux_surf',ok_flux_surf)
-
-!Config  Key  = ok_prescr_ust
-!Config  Desc = ustar impose ou non
-!Config  Def  = false
-!Config  Help = ustar impose ou non
-       ok_prescr_ust = .false.
-       CALL getin('ok_prescr_ust',ok_prescr_ust)
-
-!Config  Key  = ok_old_disvert
-!Config  Desc = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
-!Config  Def  = false
-!Config  Help = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
-       ok_old_disvert = .FALSE.
-       CALL getin('ok_old_disvert',ok_old_disvert)
-
-!Config  Key  = time_ini
-!Config  Desc = meaningless in this  case
-!Config  Def  = 0.
-!Config  Help = 
-       tsurf = 0.
-       CALL getin('time_ini',time_ini)
-
-!Config  Key  = rlat et rlon
-!Config  Desc = latitude et longitude
-!Config  Def  = 0.0  0.0
-!Config  Help = fixe la position de la colonne
-       xlat = 0.
-       xlon = 0.
-       CALL getin('rlat',xlat)
-       CALL getin('rlon',xlon)
-
-!Config  Key  = airephy
-!Config  Desc = Grid cell area
-!Config  Def  = 1.e11
-!Config  Help = 
-       airefi = 1.e11
-       CALL getin('airephy',airefi)
-
-!Config  Key  = nat_surf
-!Config  Desc = surface type
-!Config  Def  = 0 (ocean)
-!Config  Help = 0=ocean,1=land,2=glacier,3=banquise
-       nat_surf = 0.
-       CALL getin('nat_surf',nat_surf)
-
-!Config  Key  = tsurf
-!Config  Desc = surface temperature
-!Config  Def  = 290.
-!Config  Help = not used if type_ts_forcing=1 in lmdz1d.F
-       tsurf = 290.
-       CALL getin('tsurf',tsurf)
-
-!Config  Key  = psurf
-!Config  Desc = surface pressure
-!Config  Def  = 102400.
-!Config  Help = 
-       psurf = 102400.
-       CALL getin('psurf',psurf)
-
-!Config  Key  = zsurf
-!Config  Desc = surface altitude
-!Config  Def  = 0.
-!Config  Help = 
-       zsurf = 0.
-       CALL getin('zsurf',zsurf)
-
-!Config  Key  = rugos
-!Config  Desc = coefficient de frottement
-!Config  Def  = 0.0001
-!Config  Help = calcul du Cdrag
-       rugos = 0.0001
-       CALL getin('rugos',rugos)
-
-!Config  Key  = wtsurf et wqsurf
-!Config  Desc = ???
-!Config  Def  = 0.0 0.0
-!Config  Help = 
-       wtsurf = 0.0
-       wqsurf = 0.0
-       CALL getin('wtsurf',wtsurf)
-       CALL getin('wqsurf',wqsurf)
-
-!Config  Key  = albedo
-!Config  Desc = albedo
-!Config  Def  = 0.09
-!Config  Help = 
-       albedo = 0.09
-       CALL getin('albedo',albedo)
-
-!Config  Key  = agesno
-!Config  Desc = age de la neige
-!Config  Def  = 30.0
-!Config  Help = 
-       xagesno = 30.0
-       CALL getin('agesno',xagesno)
-
-!Config  Key  = restart_runoff
-!Config  Desc = age de la neige
-!Config  Def  = 30.0
-!Config  Help = 
-       restart_runoff = 0.0
-       CALL getin('restart_runoff',restart_runoff)
-
-!Config  Key  = qsolinp
-!Config  Desc = initial bucket water content (kg/m2) when land (5std)
-!Config  Def  = 30.0
-!Config  Help = 
-       qsolinp = 1.
-       CALL getin('qsolinp',qsolinp)
-
-!Config  Key  = zpicinp
-!Config  Desc = denivellation orographie
-!Config  Def  = 300.
-!Config  Help =  input brise
-       zpicinp = 300.
-       CALL getin('zpicinp',zpicinp)
-!Config key = nudge_tsoil
-!Config  Desc = activation of soil temperature nudging
-!Config  Def  = .FALSE.
-!Config  Help = ...
-
-       nudge_tsoil=.FALSE.
-       CALL getin('nudge_tsoil',nudge_tsoil)
-
-!Config key = isoil_nudge
-!Config  Desc = level number where soil temperature is nudged
-!Config  Def  = 3
-!Config  Help = ...
-
-       isoil_nudge=3
-       CALL getin('isoil_nudge',isoil_nudge)
-
-!Config key = Tsoil_nudge
-!Config  Desc = target temperature for tsoil(isoil_nudge)
-!Config  Def  = 300.
-!Config  Help = ...
-
-       Tsoil_nudge=300.
-       CALL getin('Tsoil_nudge',Tsoil_nudge)
-
-!Config key = tau_soil_nudge
-!Config  Desc = nudging relaxation time for tsoil
-!Config  Def  = 3600.
-!Config  Help = ...
-
-       tau_soil_nudge=3600.
-       CALL getin('tau_soil_nudge',tau_soil_nudge)
-
-
-
-
-      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
-      write(lunout,*)' Configuration des parametres du gcm1D: '
-      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
-      write(lunout,*)' restart = ', restart
-      write(lunout,*)' forcing_type = ', forcing_type
-      write(lunout,*)' time_ini = ', time_ini
-      write(lunout,*)' rlat = ', xlat
-      write(lunout,*)' rlon = ', xlon
-      write(lunout,*)' airephy = ', airefi
-      write(lunout,*)' nat_surf = ', nat_surf
-      write(lunout,*)' tsurf = ', tsurf
-      write(lunout,*)' psurf = ', psurf
-      write(lunout,*)' zsurf = ', zsurf
-      write(lunout,*)' rugos = ', rugos
-      write(lunout,*)' wtsurf = ', wtsurf
-      write(lunout,*)' wqsurf = ', wqsurf
-      write(lunout,*)' albedo = ', albedo
-      write(lunout,*)' xagesno = ', xagesno
-      write(lunout,*)' restart_runoff = ', restart_runoff
-      write(lunout,*)' qsolinp = ', qsolinp
-      write(lunout,*)' zpicinp = ', zpicinp
-      write(lunout,*)' nudge_tsoil = ', nudge_tsoil
-      write(lunout,*)' isoil_nudge = ', isoil_nudge
-      write(lunout,*)' Tsoil_nudge = ', Tsoil_nudge
-      write(lunout,*)' tau_soil_nudge = ', tau_soil_nudge
-      IF (forcing_type .eq.40) THEN
-        write(lunout,*) '--- Forcing type GCSS Old --- with:'
-        write(lunout,*)'imp_fcg',imp_fcg_gcssold
-        write(lunout,*)'ts_fcg',ts_fcg_gcssold
-        write(lunout,*)'tp_fcg',Tp_fcg_gcssold
-        write(lunout,*)'tp_ini',Tp_ini_gcssold
-        write(lunout,*)'xturb_fcg',xTurb_fcg_gcssold
-      ENDIF
-
-      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
-      write(lunout,*)
-!
-      RETURN
-      END
-!
-! $Id: dyn1deta0.F 1279 2010/07/30 A Lahellec$
-!
-!
-      SUBROUTINE dyn1deta0(fichnom,plev,play,phi,phis,presnivs,                 &
-     &                          ucov,vcov,temp,q,omega2)
-      USE dimphy
-      USE mod_grid_phy_lmdz
-      USE mod_phys_lmdz_para
-      USE iophy
-      USE phys_state_var_mod
-      USE iostart
-      USE write_field_phy
-      USE infotrac
-      use control_mod
-
-      IMPLICIT NONE
-!=======================================================
-! Ecriture du fichier de redemarrage sous format NetCDF
-!=======================================================
-!   Declarations:
-!   -------------
-#include "dimensions.h"
-#include "comconst.h"
-#include "temps.h"
-!!#include "control.h"
-#include "logic.h"
-#include "netcdf.inc"
-
-!   Arguments:
-!   ----------
-      CHARACTER*(*) fichnom
-!Al1 plev tronque pour .nc mais plev(klev+1):=0
-      real :: plev(klon,klev+1),play (klon,klev),phi(klon,klev)
-      real :: presnivs(klon,klev)
-      real :: ucov(klon,klev),vcov(klon,klev),temp(klon,klev)
-      real :: q(klon,klev,nqtot),omega2(klon,klev)
-!      real :: ug(klev),vg(klev),fcoriolis
-      real :: phis(klon) 
-
-!   Variables locales pour NetCDF:
-!   ------------------------------
-      INTEGER iq
-      INTEGER length
-      PARAMETER (length = 100)
-      REAL tab_cntrl(length) ! tableau des parametres du run
-      character*4 nmq(nqtot)
-      character*12 modname
-      character*80 abort_message
-      LOGICAL found
-
-      modname = 'dyn1deta0 : '
-      nmq(1)="vap"
-      nmq(2)="cond"
-      do iq=3,nqtot
-        write(nmq(iq),'("tra",i1)') iq-2
-      enddo
-      print*,'in dyn1deta0 ',fichnom,klon,klev,nqtot
-      CALL open_startphy(fichnom)
-      print*,'after open startphy ',fichnom,nmq
-
-!
-! Lecture des parametres de controle:
-!
-      CALL get_var("controle",tab_cntrl)
-       
-
-      im         = tab_cntrl(1)
-      jm         = tab_cntrl(2)
-      lllm       = tab_cntrl(3)
-      day_ref    = tab_cntrl(4)
-      annee_ref  = tab_cntrl(5)
-!      rad        = tab_cntrl(6)
-!      omeg       = tab_cntrl(7)
-!      g          = tab_cntrl(8)
-!      cpp        = tab_cntrl(9)
-!      kappa      = tab_cntrl(10)
-!      daysec     = tab_cntrl(11)
-!      dtvr       = tab_cntrl(12)
-!      etot0      = tab_cntrl(13)
-!      ptot0      = tab_cntrl(14)
-!      ztot0      = tab_cntrl(15)
-!      stot0      = tab_cntrl(16)
-!      ang0       = tab_cntrl(17)
-!      pa         = tab_cntrl(18)
-!      preff      = tab_cntrl(19)
-!
-!      clon       = tab_cntrl(20)
-!      clat       = tab_cntrl(21)
-!      grossismx  = tab_cntrl(22)
-!      grossismy  = tab_cntrl(23)
-!
-      IF ( tab_cntrl(24).EQ.1. )  THEN
-        fxyhypb  =.true.
-!        dzoomx   = tab_cntrl(25)
-!        dzoomy   = tab_cntrl(26)
-!        taux     = tab_cntrl(28)
-!        tauy     = tab_cntrl(29)
-      ELSE
-        fxyhypb = .false.
-        ysinus  = .false.
-        IF( tab_cntrl(27).EQ.1. ) ysinus =.true. 
-      ENDIF
-
-      day_ini = tab_cntrl(30)
-      itau_dyn = tab_cntrl(31)
-!   .................................................................
-!
-!
-!      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
-!Al1
-       Print*,'day_ref,annee_ref,day_ini,itau_dyn',                         &
-     &              day_ref,annee_ref,day_ini,itau_dyn
-
-!  Lecture des champs
-!
-      CALL get_field("play",play,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <Play> est absent'
-      CALL get_field("phi",phi,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <Phi> est absent'
-      CALL get_field("phis",phis,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <Phis> est absent'
-      CALL get_field("presnivs",presnivs,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <Presnivs> est absent'
-      CALL get_field("ucov",ucov,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <ucov> est absent'
-      CALL get_field("vcov",vcov,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <vcov> est absent'
-      CALL get_field("temp",temp,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <temp> est absent'
-      CALL get_field("omega2",omega2,found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <omega2> est absent'
-      plev(1,klev+1)=0.
-      CALL get_field("plev",plev(:,1:klev),found)
-      IF (.NOT. found) PRINT*, modname//'Le champ <Plev> est absent'
-
-      Do iq=1,nqtot
-        CALL get_field("q"//nmq(iq),q(:,:,iq),found)
-        IF (.NOT.found)PRINT*, modname//'Le champ <q'//nmq//'> est absent'
-      EndDo
-
-      CALL close_startphy
-      print*,' close startphy',fichnom,play(1,1),play(1,klev),temp(1,klev)
-!
-      RETURN
-      END
-!
-! $Id: dyn1dredem.F 1279 2010/07/29 A Lahellec$
-!
-!
-      SUBROUTINE dyn1dredem(fichnom,plev,play,phi,phis,presnivs,           &
-     &                          ucov,vcov,temp,q,omega2)
-      USE dimphy
-      USE mod_grid_phy_lmdz
-      USE mod_phys_lmdz_para
-      USE phys_state_var_mod
-      USE iostart
-      USE infotrac
-      use control_mod
-
-      IMPLICIT NONE
-!=======================================================
-! Ecriture du fichier de redemarrage sous format NetCDF
-!=======================================================
-!   Declarations:
-!   -------------
-#include "dimensions.h"
-#include "comconst.h"
-#include "temps.h"
-!!#include "control.h"
-#include "logic.h"
-#include "netcdf.inc"
-
-!   Arguments:
-!   ----------
-      CHARACTER*(*) fichnom
-!Al1 plev tronque pour .nc mais plev(klev+1):=0
-      real :: plev(klon,klev),play (klon,klev),phi(klon,klev)
-      real :: presnivs(klon,klev)
-      real :: ucov(klon,klev),vcov(klon,klev),temp(klon,klev)
-      real :: q(klon,klev,nqtot)
-      real :: omega2(klon,klev),rho(klon,klev+1)
-!      real :: ug(klev),vg(klev),fcoriolis
-      real :: phis(klon) 
-
-!   Variables locales pour NetCDF:
-!   ------------------------------
-      INTEGER nid
-      INTEGER ierr
-      INTEGER iq,l
-      INTEGER length
-      PARAMETER (length = 100)
-      REAL tab_cntrl(length) ! tableau des parametres du run
-      character*4 nmq(nqtot)
-      character*20 modname
-      character*80 abort_message
-!
-      INTEGER nb
-      SAVE nb
-      DATA nb / 0 /
-
-      CALL open_restartphy(fichnom)
-      print*,'redm1 ',fichnom,klon,klev,nqtot
-      nmq(1)="vap"
-      nmq(2)="cond"
-      nmq(3)="tra1"
-      nmq(4)="tra2"
-
-      modname = 'dyn1dredem'
-      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
-      IF (ierr .NE. NF_NOERR) THEN
-         abort_message="Pb. d ouverture "//fichnom
-         CALL abort_gcm('Modele 1D',abort_message,1)
-      ENDIF
-
-      DO l=1,length
-       tab_cntrl(l) = 0.
-      ENDDO
-       tab_cntrl(1)  = FLOAT(iim)
-       tab_cntrl(2)  = FLOAT(jjm)
-       tab_cntrl(3)  = FLOAT(llm)
-       tab_cntrl(4)  = FLOAT(day_ref)
-       tab_cntrl(5)  = FLOAT(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
-!
-!    .....    parametres  pour le 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.
-      ENDIF
-!Al1 iday_end -> day_end
-       tab_cntrl(30) = FLOAT(day_end)
-       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
-!
-      CALL put_var("controle","Param. de controle Dyn1D",tab_cntrl)
-!
-
-!  Ecriture/extension de la coordonnee temps
-
-      nb = nb + 1
-
-!  Ecriture des champs
-!
-      CALL put_field("plev","p interfaces sauf la nulle",plev)
-      CALL put_field("play","",play)
-      CALL put_field("phi","geopotentielle",phi)
-      CALL put_field("phis","geopotentiell de surface",phis)
-      CALL put_field("presnivs","",presnivs)
-      CALL put_field("ucov","",ucov)
-      CALL put_field("vcov","",vcov)
-      CALL put_field("temp","",temp)
-      CALL put_field("omega2","",omega2)
-
-      Do iq=1,nqtot
-        CALL put_field("q"//nmq(iq),"eau vap ou condens et traceurs",           &
-     &                                                      q(:,:,iq))
-      EndDo
-      CALL close_restartphy
-
-!
-      RETURN
-      END
-      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
-      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 i,j,ifield,ig
- 
-!-----------------------------------------------------------------------
-!   calcul:
-!   -------
- 
-      DO ifield=1,nfield
-!   traitement des poles
-         DO i=1,im
-            pdyn(i,1,ifield)=pfi(1,ifield)
-            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
-         ENDDO
- 
-!   traitement des point normaux
-         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
- 
-      RETURN
-      END
- 
- 
-
-      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
-!     call histclo(2)
-!     call histclo(3)
-!     call histclo(4)
-!     call histclo(5)
-      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
-      REAL FUNCTION fq_sat(kelvin, millibar)
-!
-      IMPLICIT none
-!======================================================================
-! Autheur(s): Z.X. Li (LMD/CNRS)
-! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
-!======================================================================
-! Arguments:
-! kelvin---input-R: temperature en Kelvin
-! millibar--input-R: pression en mb
-!
-! fq_sat----output-R: vapeur d'eau saturante en kg/kg
-!======================================================================
-!
-      REAL kelvin, millibar
-!
-      REAL r2es
-      PARAMETER (r2es=611.14 *18.0153/28.9644)
-!
-      REAL r3les, r3ies, r3es
-      PARAMETER (R3LES=17.269)
-      PARAMETER (R3IES=21.875)
-!
-      REAL r4les, r4ies, r4es
-      PARAMETER (R4LES=35.86)
-      PARAMETER (R4IES=7.66)
-!
-      REAL rtt
-      PARAMETER (rtt=273.16)
-!
-      REAL retv
-      PARAMETER (retv=28.9644/18.0153 - 1.0)
-!
-      REAL zqsat
-      REAL temp, pres
-!     ------------------------------------------------------------------
-!
-!
-      temp = kelvin
-      pres = millibar * 100.0
-!      write(*,*)'kelvin,millibar=',kelvin,millibar
-!      write(*,*)'temp,pres=',temp,pres
-!
-      IF (temp .LE. rtt) THEN
-         r3es = r3ies
-         r4es = r4ies
-      ELSE
-         r3es = r3les
-         r4es = r4les
-      ENDIF
-!
-      zqsat=r2es/pres * EXP ( r3es*(temp-rtt) / (temp-r4es) )
-      zqsat=MIN(0.5,ZQSAT)
-      zqsat=zqsat/(1.-retv  *zqsat)
-!
-      fq_sat = zqsat
-!
-      RETURN
-      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
- 
-      SUBROUTINE disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
- 
-!    Ancienne version disvert dont on a modifie nom pour utiliser
-!    le disvert de dyn3d (qui permet d'utiliser grille avec ab,bp imposes)
-!    (MPL 18092012)
-!
-!    Auteur :  P. Le Van .
-!
-      IMPLICIT NONE
- 
-#include "dimensions.h"
-#include "paramet.h"
-!
-!=======================================================================
-!
-!
-!    s = sigma ** kappa   :  coordonnee  verticale
-!    dsig(l)            : epaisseur de la couche l ds la coord.  s
-!    sig(l)             : sigma a l'interface des couches l et l-1
-!    ds(l)              : distance entre les couches l et l-1 en coord.s
-!
-!=======================================================================
-!
-      REAL pa,preff
-      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
-      REAL presnivs(llm)
-!
-!   declarations:
-!   -------------
-!
-      REAL sig(llm+1),dsig(llm)
-!
-      INTEGER l
-      REAL snorm
-      REAL alpha,beta,gama,delta,deltaz,h
-      INTEGER np,ierr
-      REAL pi,x
- 
-!-----------------------------------------------------------------------
-!
-      pi=2.*ASIN(1.)
- 
-      OPEN(99,file='sigma.def',status='old',form='formatted',                   &
-     &   iostat=ierr)
- 
-!-----------------------------------------------------------------------
-!   cas 1 on lit les options dans sigma.def:
-!   ----------------------------------------
- 
-      IF (ierr.eq.0) THEN
- 
-      print*,'WARNING!!! on lit les options dans sigma.def'
-      READ(99,*) deltaz
-      READ(99,*) h
-      READ(99,*) beta
-      READ(99,*) gama
-      READ(99,*) delta
-      READ(99,*) np
-      CLOSE(99)
-      alpha=deltaz/(llm*h)
-!
- 
-       DO 1  l = 1, llm
-       dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*                    &
-     &          ( (tanh(gama*l)/tanh(gama*llm))**np +                      &
-     &            (1.-l/FLOAT(llm))*delta )
-   1   CONTINUE
- 
-       sig(1)=1.
-       DO 101 l=1,llm-1
-          sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
-101    CONTINUE
-       sig(llm+1)=0.
- 
-       DO 2  l = 1, llm
-       dsig(l) = sig(l)-sig(l+1)
-   2   CONTINUE
-!
- 
-      ELSE
-!-----------------------------------------------------------------------
-!   cas 2 ancienne discretisation (LMD5...):
-!   ----------------------------------------
- 
-      PRINT*,'WARNING!!! Ancienne discretisation verticale'
- 
-      h=7.
-      snorm  = 0.
-      DO l = 1, llm
-         x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
-         dsig(l) = 1.0 + 7.0 * SIN(x)**2
-         snorm = snorm + dsig(l)
-      ENDDO
-      snorm = 1./snorm
-      DO l = 1, llm
-         dsig(l) = dsig(l)*snorm
-      ENDDO
-      sig(llm+1) = 0.
-      DO l = llm, 1, -1
-         sig(l) = sig(l+1) + dsig(l)
-      ENDDO
- 
-      ENDIF
- 
- 
-      DO l=1,llm
-        nivsigs(l) = FLOAT(l)
-      ENDDO
- 
-      DO l=1,llmp1
-        nivsig(l)= FLOAT(l)
-      ENDDO
- 
-!
-!    ....  Calculs  de ap(l) et de bp(l)  ....
-!    .........................................
-!
-!
-!   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
-!
- 
-      bp(llmp1) =   0.
- 
-      DO l = 1, llm
-!c
-!cc    ap(l) = 0.
-!cc    bp(l) = sig(l)
- 
-      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
-      ap(l) = pa * ( sig(l) - bp(l) )
-!
-      ENDDO
-      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
- 
-      PRINT *,' BP '
-      PRINT *,  bp
-      PRINT *,' AP '
-      PRINT *,  ap
- 
-      DO l = 1, llm
-       dpres(l) = bp(l) - bp(l+1)
-       presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
-      ENDDO
- 
-      PRINT *,' PRESNIVS '
-      PRINT *,presnivs
- 
-      RETURN
-      END
-
-!======================================================================
-       SUBROUTINE read_tsurf1d(knon,sst_out)
-
-! This subroutine specifies the surface temperature to be used in 1D simulations
-
-      USE dimphy, ONLY : klon
-
-      INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
-      REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out  ! tsurf used to force the single-column model
-
-       INTEGER :: i
-! COMMON defined in lmdz1d.F:
-       real ts_cur
-       common /sst_forcing/ts_cur
-
-       DO i = 1, knon
-        sst_out(i) = ts_cur
-       ENDDO
-
-      END SUBROUTINE read_tsurf1d
-
-!===============================================================
-      subroutine advect_vert(llm,w,dt,q,plev)
-!===============================================================
-!   Schema amont pour l'advection verticale en 1D
-!   w est la vitesse verticale dp/dt en Pa/s
-!   Traitement en volumes finis 
-!   d / dt ( zm q ) = delta_z ( omega q )
-!   d / dt ( zm ) = delta_z ( omega )
-!   avec zm = delta_z ( p )
-!   si * designe la valeur au pas de temps t+dt
-!   zm*(l) q*(l) - zm(l) q(l) = w(l+1) q(l+1) - w(l) q(l)
-!   zm*(l) -zm(l) = w(l+1) - w(l)
-!   avec w=omega * dt
-!---------------------------------------------------------------
-      implicit none
-! arguments
-      integer llm
-      real w(llm+1),q(llm),plev(llm+1),dt
-
-! local
-      integer l
-      real zwq(llm+1),zm(llm+1),zw(llm+1)
-      real qold
-
-!---------------------------------------------------------------
-
-      do l=1,llm
-         zw(l)=dt*w(l)
-         zm(l)=plev(l)-plev(l+1)
-         zwq(l)=q(l)*zw(l)
-      enddo
-      zwq(llm+1)=0.
-      zw(llm+1)=0.
- 
-      do l=1,llm
-         qold=q(l)
-         q(l)=(q(l)*zm(l)+zwq(l+1)-zwq(l))/(zm(l)+zw(l+1)-zw(l))
-         print*,'ADV Q ',zm(l),zw(l),zwq(l),qold,q(l)
-      enddo
-
- 
-      return
-      end
-
-!===============================================================
-
-
-       SUBROUTINE advect_va(llm,omega,d_t_va,d_q_va,d_u_va,d_v_va,              &
-     &                q,temp,u,v,play)
-!itlmd 
-!----------------------------------------------------------------------
-!   Calcul de l'advection verticale (ascendance et subsidence) de 
-!   température et d'humidité. Hypothèse : ce qui rentre de l'extérieur
-!   a les mêmes caractéristiques que l'air de la colonne 1D (WTG) ou 
-!   sans WTG rajouter une advection horizontale 
-!----------------------------------------------------------------------  
-        implicit none
-#include "YOMCST.h"
-!        argument
-        integer llm
-        real  omega(llm+1),d_t_va(llm), d_q_va(llm,3)
-        real  d_u_va(llm), d_v_va(llm)
-        real  q(llm,3),temp(llm)
-        real  u(llm),v(llm)
-        real  play(llm)
-! interne
-        integer l
-        real alpha,omgdown,omgup
-
-      do l= 1,llm
-       if(l.eq.1) then
-!si omgup pour la couche 1, alors tendance nulle
-        omgdown=max(omega(2),0.0)
-        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
-        d_t_va(l)= alpha*(omgdown)-omgdown*(temp(l)-temp(l+1))             &
-     &       /(play(l)-play(l+1))
-
-        d_q_va(l,:)= -omgdown*(q(l,:)-q(l+1,:))/(play(l)-play(l+1))              
-
-        d_u_va(l)= -omgdown*(u(l)-u(l+1))/(play(l)-play(l+1))              
-        d_v_va(l)= -omgdown*(v(l)-v(l+1))/(play(l)-play(l+1))              
-
-        
-       elseif(l.eq.llm) then
-        omgup=min(omega(l),0.0)
-        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
-        d_t_va(l)= alpha*(omgup)-                                          &
-
-!bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
-     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-play(l))
-        d_q_va(l,:)= -omgup*(q(l-1,:)-q(l,:))/(play(l-1)-play(l))
-        d_u_va(l)= -omgup*(u(l-1)-u(l))/(play(l-1)-play(l))
-        d_v_va(l)= -omgup*(v(l-1)-v(l))/(play(l-1)-play(l))
-       
-       else
-        omgup=min(omega(l),0.0)
-        omgdown=max(omega(l+1),0.0)
-        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
-        d_t_va(l)= alpha*(omgup+omgdown)-omgdown*(temp(l)-temp(l+1))       &
-     &              /(play(l)-play(l+1))-                                  &
-!bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
-     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-play(l))
-!      print*, '  ??? '
-
-        d_q_va(l,:)= -omgdown*(q(l,:)-q(l+1,:))                            &
-     &              /(play(l)-play(l+1))-                                  &
-     &              omgup*(q(l-1,:)-q(l,:))/(play(l-1)-play(l)) 
-        d_u_va(l)= -omgdown*(u(l)-u(l+1))                                  &
-     &              /(play(l)-play(l+1))-                                  &
-     &              omgup*(u(l-1)-u(l))/(play(l-1)-play(l)) 
-        d_v_va(l)= -omgdown*(v(l)-v(l+1))                                  &
-     &              /(play(l)-play(l+1))-                                  &
-     &              omgup*(v(l-1)-v(l))/(play(l-1)-play(l))
-       
-      endif
-         
-      enddo
-!fin itlmd
-        return
-        end
-!       SUBROUTINE lstendH(llm,omega,d_t_va,d_q_va,d_u_va,d_v_va,
-       SUBROUTINE lstendH(llm,nqtot,omega,d_t_va,d_q_va,                        &
-     &                q,temp,u,v,play)
-!itlmd 
-!----------------------------------------------------------------------
-!   Calcul de l'advection verticale (ascendance et subsidence) de 
-!   température et d'humidité. Hypothèse : ce qui rentre de l'extérieur
-!   a les mêmes caractéristiques que l'air de la colonne 1D (WTG) ou 
-!   sans WTG rajouter une advection horizontale 
-!----------------------------------------------------------------------  
-        implicit none
-#include "YOMCST.h"
-!        argument
-        integer llm,nqtot
-        real  omega(llm+1),d_t_va(llm), d_q_va(llm,nqtot)
-!        real  d_u_va(llm), d_v_va(llm)
-        real  q(llm,nqtot),temp(llm)
-        real  u(llm),v(llm)
-        real  play(llm)
-        real cor(llm)
-!        real dph(llm),dudp(llm),dvdp(llm),dqdp(llm),dtdp(llm)
-        real dph(llm),dqdp(llm),dtdp(llm)
-! interne
-        integer k
-        real omdn,omup
-
-!        dudp=0.
-!        dvdp=0.
-        dqdp=0.
-        dtdp=0.
-!        d_u_va=0.
-!        d_v_va=0.
-
-      cor(:) = rkappa*temp*(1.+q(:,1)*rv/rd)/(play*(1.+q(:,1)))
-
-
-      do k=2,llm-1
-
-       dph  (k-1) = (play(k  )- play(k-1  ))
-!       dudp (k-1) = (u   (k  )- u   (k-1  ))/dph(k-1)
-!       dvdp (k-1) = (v   (k  )- v   (k-1  ))/dph(k-1)
-       dqdp (k-1) = (q   (k,1)- q   (k-1,1))/dph(k-1)
-       dtdp (k-1) = (temp(k  )- temp(k-1  ))/dph(k-1)
-
-      enddo
-
-!      dudp (  llm  ) = dudp ( llm-1 )
-!      dvdp (  llm  ) = dvdp ( llm-1 )
-      dqdp (  llm  ) = dqdp ( llm-1 )
-      dtdp (  llm  ) = dtdp ( llm-1 )
-
-      do k=2,llm-1
-      omdn=max(0.0,omega(k+1))
-      omup=min(0.0,omega( k ))
-
-!      d_u_va(k)  = -omdn*dudp(k)-omup*dudp(k-1)
-!      d_v_va(k)  = -omdn*dvdp(k)-omup*dvdp(k-1)
-      d_q_va(k,1)= -omdn*dqdp(k)-omup*dqdp(k-1)
-      d_t_va(k)  = -omdn*dtdp(k)-omup*dtdp(k-1)+(omup+omdn)*cor(k)
-      enddo
-
-      omdn=max(0.0,omega( 2 ))
-      omup=min(0.0,omega(llm))
-!      d_u_va( 1 )   = -omdn*dudp( 1 )
-!      d_u_va(llm)   = -omup*dudp(llm)
-!      d_v_va( 1 )   = -omdn*dvdp( 1 )
-!      d_v_va(llm)   = -omup*dvdp(llm)
-      d_q_va( 1 ,1) = -omdn*dqdp( 1 )
-      d_q_va(llm,1) = -omup*dqdp(llm)
-      d_t_va( 1 )   = -omdn*dtdp( 1 )+omdn*cor( 1 )
-      d_t_va(llm)   = -omup*dtdp(llm)!+omup*cor(llm)
-
-!      if(abs(rlat(1))>10.) then
-!     Calculate the tendency due agestrophic motions
-!      du_age = fcoriolis*(v-vg)
-!      dv_age = fcoriolis*(ug-u)
-!      endif
-
-!       call writefield_phy('d_t_va',d_t_va,llm)
-
-          return
-         end
-
-!======================================================================
-      SUBROUTINE read_togacoare(fich_toga,nlev_toga,nt_toga                     &
-     &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga        &
-     &             ,ht_toga,vt_toga,hq_toga,vq_toga)
-      implicit none
-
-!-------------------------------------------------------------------------
-! Read TOGA-COARE forcing data 
-!-------------------------------------------------------------------------
-
-      integer nlev_toga,nt_toga
-      real ts_toga(nt_toga),plev_toga(nlev_toga,nt_toga)
-      real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)
-      real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)
-      real w_toga(nlev_toga,nt_toga)
-      real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
-      real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
-      character*80 fich_toga
-
-      integer k,ip
-      real bid
-
-      integer iy,im,id,ih
-      
-       real plev_min
-
-       plev_min = 55.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
-
-      open(21,file=trim(fich_toga),form='formatted')
-      read(21,'(a)') 
-      do ip = 1, nt_toga
-      read(21,'(a)') 
-      read(21,'(a)') 
-      read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid
-      read(21,'(a)') 
-      read(21,'(a)') 
-
-       do k = 1, nlev_toga
-         read(21,230) plev_toga(k,ip), t_toga(k,ip), q_toga(k,ip)          &
-     &       ,u_toga(k,ip), v_toga(k,ip), w_toga(k,ip)                     &
-     &       ,ht_toga(k,ip), vt_toga(k,ip), hq_toga(k,ip), vq_toga(k,ip)
-
-! conversion in SI units:
-         t_toga(k,ip)=t_toga(k,ip)+273.15     ! K
-         q_toga(k,ip)=q_toga(k,ip)*0.001      ! kg/kg
-         w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s
-! no water vapour tendency above 55 hPa
-         if (plev_toga(k,ip) .lt. plev_min) then
-          q_toga(k,ip) = 0.
-          hq_toga(k,ip) = 0.
-          vq_toga(k,ip) =0.
-         endif
-       enddo
-
-         ts_toga(ip)=ts_toga(ip)+273.15       ! K
-       enddo
-       close(21)
-
-  223 format(4i3,6f8.2)
-  230 format(6f9.3,4e11.3)
-
-          return
-          end
-
-!-------------------------------------------------------------------------
-      SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
-      implicit none
-
-!-------------------------------------------------------------------------
-! Read I.SANDU case forcing data
-!-------------------------------------------------------------------------
-
-      integer nlev_sandu,nt_sandu
-      real ts_sandu(nt_sandu)
-      character*80 fich_sandu
-
-      integer ip
-      integer iy,im,id,ih
-
-      real plev_min
-
-      print*,'nlev_sandu',nlev_sandu
-      plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
-
-      open(21,file=trim(fich_sandu),form='formatted')
-      read(21,'(a)')
-      do ip = 1, nt_sandu
-      read(21,'(a)')
-      read(21,'(a)')
-      read(21,223) iy, im, id, ih, ts_sandu(ip)
-      print *,'ts=',iy,im,id,ih,ip,ts_sandu(ip)
-      enddo
-      close(21)
-
-  223 format(4i3,f8.2)
-
-          return
-          end
-
-!=====================================================================
-!-------------------------------------------------------------------------
-      SUBROUTINE read_astex(fich_astex,nlev_astex,nt_astex,div_astex,      &
-     & ts_astex,ug_astex,vg_astex,ufa_astex,vfa_astex)
-      implicit none
-
-!-------------------------------------------------------------------------
-! Read Astex case forcing data
-!-------------------------------------------------------------------------
-
-      integer nlev_astex,nt_astex
-      real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
-      real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
-      character*80 fich_astex
-
-      integer ip
-      integer iy,im,id,ih
-
-       real plev_min
-
-      print*,'nlev_astex',nlev_astex
-       plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
-
-      open(21,file=trim(fich_astex),form='formatted')
-      read(21,'(a)')
-      read(21,'(a)')
-      do ip = 1, nt_astex
-      read(21,'(a)')
-      read(21,'(a)')
-      read(21,223) iy, im, id, ih, div_astex(ip),ts_astex(ip),             &
-     &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vfa_astex(ip)
-      ts_astex(ip)=ts_astex(ip)+273.15
-      print *,'ts=',iy,im,id,ih,ip,div_astex(ip),ts_astex(ip),             &
-     &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vg_astex(ip)
-      enddo
-      close(21)
-
-  223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)
-
-          return
-          end
-!=====================================================================
-      subroutine read_twpice(fich_twpice,nlevel,ntime                       &
-     &     ,T_srf,plev,T,q,u,v,omega                                       &
-     &     ,T_adv_h,T_adv_v,q_adv_h,q_adv_v)
-
-!program reading forcings of the TWP-ICE experiment
-
-!      use netcdf
-
-      implicit none
-
-#include "netcdf.inc"
-
-      integer ntime,nlevel
-      integer l,k
-      character*80 :: fich_twpice
-      real*8 time(ntime)
-      real*8 lat, lon, alt, phis
-      real*8 lev(nlevel)
-      real*8 plev(nlevel,ntime)
-
-      real*8 T(nlevel,ntime)
-      real*8 q(nlevel,ntime),u(nlevel,ntime)
-      real*8 v(nlevel,ntime)
-      real*8 omega(nlevel,ntime), div(nlevel,ntime)
-      real*8 T_adv_h(nlevel,ntime)
-      real*8 T_adv_v(nlevel,ntime), q_adv_h(nlevel,ntime)
-      real*8 q_adv_v(nlevel,ntime)
-      real*8 s(nlevel,ntime), s_adv_h(nlevel,ntime)
-      real*8 s_adv_v(nlevel,ntime)
-      real*8 p_srf_aver(ntime), p_srf_center(ntime)
-      real*8 T_srf(ntime)
-
-      integer nid, ierr
-      integer nbvar3d
-      parameter(nbvar3d=20)
-      integer var3didin(nbvar3d)
-
-      ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)
-      if (ierr.NE.NF_NOERR) then
-         write(*,*) 'ERROR: Pb opening forcings cdf file '
-         write(*,*) NF_STRERROR(ierr)
-         stop ""
-      endif
-
-      ierr=NF_INQ_VARID(nid,"lat",var3didin(1))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lat'
-         endif
-      
-       ierr=NF_INQ_VARID(nid,"lon",var3didin(2))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lon'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"alt",var3didin(3))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'alt'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"phis",var3didin(4))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'phis'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"T",var3didin(5))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'T'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"q",var3didin(6))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'q'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"u",var3didin(7))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'u'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"v",var3didin(8))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"omega",var3didin(9))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'omega'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"div",var3didin(10))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'div'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'T_adv_h'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'T_adv_v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'q_adv_h'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'q_adv_v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"s",var3didin(15))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 's'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 's_adv_h'
-         endif
-    
-      ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 's_adv_v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'p_srf_aver'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'p_srf_center'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'T_srf'
-         endif
-
-!dimensions lecture
-      call catchaxis(nid,ntime,nlevel,time,lev,ierr)
-
-!pressure 
-       do l=1,ntime
-       do k=1,nlevel
-          plev(k,l)=lev(k)
-       enddo
-       enddo
-          
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture lat ok',lat
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture lon ok',lon
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture alt ok',alt
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture phis ok',phis
-          
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture T ok'
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture q ok'
-!q in kg/kg
-       do l=1,ntime
-       do k=1,nlevel
-          q(k,l)=q(k,l)/1000.
-       enddo
-       enddo
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture u ok'
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture v ok'
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture omega ok'
-!omega in mb/hour
-       do l=1,ntime
-       do k=1,nlevel
-          omega(k,l)=omega(k,l)*100./3600.
-       enddo
-       enddo
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture div ok'
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture T_adv_h ok'
-!T adv in K/s
-       do l=1,ntime
-       do k=1,nlevel
-          T_adv_h(k,l)=T_adv_h(k,l)/3600.
-       enddo
-       enddo
-
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture T_adv_v ok'
-!T adv in K/s
-       do l=1,ntime
-       do k=1,nlevel
-          T_adv_v(k,l)=T_adv_v(k,l)/3600.
-       enddo
-       enddo
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture q_adv_h ok'
-!q adv in kg/kg/s
-       do l=1,ntime
-       do k=1,nlevel
-          q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.
-       enddo
-       enddo
-
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture q_adv_v ok'
-!q adv in kg/kg/s
-       do l=1,ntime
-       do k=1,nlevel
-          q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.
-       enddo
-       enddo
-
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture T_srf ok', T_srf
-
-         return 
-         end subroutine read_twpice
-!=====================================================================
-         subroutine catchaxis(nid,ttm,llm,time,lev,ierr)
-
-!         use netcdf
-
-         implicit none
-#include "netcdf.inc"
-         integer nid,ttm,llm
-         real*8 time(ttm)
-         real*8 lev(llm)
-         integer ierr
-
-         integer timevar,levvar
-         integer timelen,levlen
-         integer timedimin,levdimin
-
-! Control & lecture on dimensions
-! ===============================
-         ierr=NF_INQ_DIMID(nid,"time",timedimin)
-         ierr=NF_INQ_VARID(nid,"time",timevar)
-         if (ierr.NE.NF_NOERR) then
-            write(*,*) 'ERROR: Field <time> is missing'
-            stop ""  
-         endif
-         ierr=NF_INQ_DIMLEN(nid,timedimin,timelen)
-
-         ierr=NF_INQ_DIMID(nid,"lev",levdimin)
-         ierr=NF_INQ_VARID(nid,"lev",levvar)
-         if (ierr.NE.NF_NOERR) then
-             write(*,*) 'ERROR: Field <lev> is lacking'
-             stop "" 
-         endif
-         ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)
-
-         if((timelen/=ttm).or.(levlen/=llm)) then
-            write(*,*) 'ERROR: Not the good lenght for axis'
-            write(*,*) 'longitude: ',timelen,ttm+1
-            write(*,*) 'latitude: ',levlen,llm
-            stop ""  
-         endif
-
-!#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)
-         ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)
-!#else
-!        ierr = NF_GET_VAR_REAL(nid,timevar,time)
-!        ierr = NF_GET_VAR_REAL(nid,levvar,lev)
-!#endif
-
-       return
-       end
-!=====================================================================
-
-       SUBROUTINE interp_sandu_vertical(play,nlev_sandu,plev_prof          &
-     &         ,t_prof,thl_prof,q_prof,u_prof,v_prof,w_prof                &
-     &         ,omega_prof,o3mmr_prof                                      &
-     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                      &
-     &         ,omega_mod,o3mmr_mod,mxcalc)
-
-       implicit none
-
-#include "dimensions.h"
-
-!-------------------------------------------------------------------------
-! Vertical interpolation of SANDUREF forcing data onto model levels
-!-------------------------------------------------------------------------
-
-       integer nlevmax
-       parameter (nlevmax=41)
-       integer nlev_sandu,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_prof(nlev_sandu)
-       real t_prof(nlev_sandu),thl_prof(nlev_sandu),q_prof(nlev_sandu)
-       real u_prof(nlev_sandu),v_prof(nlev_sandu), w_prof(nlev_sandu)
-       real omega_prof(nlev_sandu),o3mmr_prof(nlev_sandu)
-
-       real t_mod(llm),thl_mod(llm),q_mod(llm)
-       real u_mod(llm),v_mod(llm), w_mod(llm)
-       real omega_mod(llm),o3mmr_mod(llm)
-
-       integer l,k,k1,k2
-       real frac,frac1,frac2,fact
-
-       do l = 1, llm
-
-        if (play(l).ge.plev_prof(nlev_sandu)) then
-
-        mxcalc=l
-         k1=0
-         k2=0
-
-         if (play(l).le.plev_prof(1)) then
-
-         do k = 1, nlev_sandu-1
-          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_sandu-1
-          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
-         enddo
-         endif
-
-         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
-         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
-         thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
-         q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
-         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
-         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
-         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
-         omega_mod(l)=omega_prof(k2)-frac*(omega_prof(k2)-omega_prof(k1))
-         o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
-
-         else !play>plev_prof(1)
-
-         k1=1
-         k2=2
-         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
-         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
-         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
-         thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
-         q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
-         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
-         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
-         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
-         omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
-         o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
-
-         endif ! play.le.plev_prof(1)
-
-        else ! above max altitude of forcing file
-
-!jyg
-         fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg
-         fact = max(fact,0.)                                           !jyg
-         fact = exp(-fact)                                             !jyg
-         t_mod(l)= t_prof(nlev_sandu)                                   !jyg
-         thl_mod(l)= thl_prof(nlev_sandu)                                   !jyg
-         q_mod(l)= q_prof(nlev_sandu)*fact                              !jyg
-         u_mod(l)= u_prof(nlev_sandu)*fact                              !jyg
-         v_mod(l)= v_prof(nlev_sandu)*fact                              !jyg
-         w_mod(l)= w_prof(nlev_sandu)*fact                              !jyg
-         omega_mod(l)= omega_prof(nlev_sandu)*fact                      !jyg
-         o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact                      !jyg
-
-        endif ! play
-
-       enddo ! l
-
-       do l = 1,llm
-!      print *,'t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l) ',
-!    $        l,t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l)
-       enddo
-
-          return
-          end
-!=====================================================================
-       SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof          &
-     &         ,t_prof,thl_prof,qv_prof,ql_prof,qt_prof,u_prof,v_prof      &
-     &         ,w_prof,tke_prof,o3mmr_prof                                 &
-     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod       &
-     &         ,tke_mod,o3mmr_mod,mxcalc)
-
-       implicit none
-
-#include "dimensions.h"
-
-!-------------------------------------------------------------------------
-! Vertical interpolation of Astex forcing data onto model levels
-!-------------------------------------------------------------------------
-
-       integer nlevmax
-       parameter (nlevmax=41)
-       integer nlev_astex,mxcalc
-!       real play(llm), plev_prof(nlevmax)
-!       real t_prof(nlevmax),qv_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_prof(nlev_astex)
-       real t_prof(nlev_astex),thl_prof(nlev_astex),qv_prof(nlev_astex)
-       real u_prof(nlev_astex),v_prof(nlev_astex), w_prof(nlev_astex)
-       real o3mmr_prof(nlev_astex),ql_prof(nlev_astex)
-       real qt_prof(nlev_astex),tke_prof(nlev_astex)
-
-       real t_mod(llm),thl_mod(llm),qv_mod(llm)
-       real u_mod(llm),v_mod(llm), w_mod(llm),tke_mod(llm)
-       real o3mmr_mod(llm),ql_mod(llm),qt_mod(llm)
-
-       integer l,k,k1,k2
-       real frac,frac1,frac2,fact
-
-       do l = 1, llm
-
-        if (play(l).ge.plev_prof(nlev_astex)) then
-
-        mxcalc=l
-         k1=0
-         k2=0
-
-         if (play(l).le.plev_prof(1)) then
-
-         do k = 1, nlev_astex-1
-          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_astex-1
-          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
-         enddo
-         endif
-
-         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
-         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
-         thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
-         qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
-         ql_mod(l)= ql_prof(k2) - frac*(ql_prof(k2)-ql_prof(k1))
-         qt_mod(l)= qt_prof(k2) - frac*(qt_prof(k2)-qt_prof(k1))
-         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
-         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
-         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
-         tke_mod(l)= tke_prof(k2) - frac*(tke_prof(k2)-tke_prof(k1))
-         o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
-
-         else !play>plev_prof(1)
-
-         k1=1
-         k2=2
-         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
-         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
-         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
-         thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
-         qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
-         ql_mod(l)= frac1*ql_prof(k1) - frac2*ql_prof(k2)
-         qt_mod(l)= frac1*qt_prof(k1) - frac2*qt_prof(k2)
-         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
-         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
-         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
-         tke_mod(l)= frac1*tke_prof(k1) - frac2*tke_prof(k2)
-         o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
-
-         endif ! play.le.plev_prof(1)
-
-        else ! above max altitude of forcing file
-
-!jyg
-         fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg
-         fact = max(fact,0.)                                           !jyg
-         fact = exp(-fact)                                             !jyg
-         t_mod(l)= t_prof(nlev_astex)                                   !jyg
-         thl_mod(l)= thl_prof(nlev_astex)                                   !jyg
-         qv_mod(l)= qv_prof(nlev_astex)*fact                              !jyg
-         ql_mod(l)= ql_prof(nlev_astex)*fact                              !jyg
-         qt_mod(l)= qt_prof(nlev_astex)*fact                              !jyg
-         u_mod(l)= u_prof(nlev_astex)*fact                              !jyg
-         v_mod(l)= v_prof(nlev_astex)*fact                              !jyg
-         w_mod(l)= w_prof(nlev_astex)*fact                              !jyg
-         tke_mod(l)= tke_prof(nlev_astex)*fact                              !jyg
-         o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact                      !jyg
-
-        endif ! play
-
-       enddo ! l
-
-       do l = 1,llm
-!      print *,'t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l) ',
-!    $        l,t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l)
-       enddo
-
-          return
-          end
-
-!======================================================================
-      SUBROUTINE read_rico(fich_rico,nlev_rico,ps_rico,play                &
-     &             ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico             &
-     &             ,dth_dyn,dqh_dyn)
-      implicit none
-
-!-------------------------------------------------------------------------
-! Read RICO forcing data 
-!-------------------------------------------------------------------------
-#include "dimensions.h"
-
-
-      integer nlev_rico
-      real ts_rico,ps_rico
-      real t_rico(llm),q_rico(llm)
-      real u_rico(llm),v_rico(llm)
-      real w_rico(llm)
-      real dth_dyn(llm)
-      real dqh_dyn(llm)
-      
-
-      real play(llm),zlay(llm)
-     
-
-      real prico(nlev_rico),zrico(nlev_rico)
-
-      character*80 fich_rico
-
-      integer k,l
-
-      
-      print*,fich_rico
-      open(21,file=trim(fich_rico),form='formatted')
-        do k=1,llm
-      zlay(k)=0.
-         enddo
-      
-        read(21,*) ps_rico,ts_rico
-        prico(1)=ps_rico
-        zrico(1)=0.0
-      do l=2,nlev_rico
-        read(21,*) k,prico(l),zrico(l)
-      enddo
-       close(21)
-
-      do k=1,llm
-        do l=1,80
-          if(prico(l)>play(k)) then
-              if(play(k)>prico(l+1)) then
-                zlay(k)=zrico(l)+(play(k)-prico(l)) *                      &
-     &              (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))
-              else 
-                zlay(k)=zrico(l)+(play(k)-prico(80))*                      &
-     &              (zrico(81)-zrico(80))/(prico(81)-prico(80))
-              endif
-          endif
-        enddo
-        print*,k,zlay(k)
-        ! U
-        if(0 < zlay(k) .and. zlay(k) < 4000) then
-          u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/4000
-        elseif(4000 < zlay(k) .and. zlay(k) < 12000) then
-       u_rico(k)=  -1.9 + (30.0 + 1.9) /                                   &
-     &          (12000 - 4000) * (zlay(k) - 4000)
-        elseif(12000 < zlay(k) .and. zlay(k) < 13000) then
-          u_rico(k)=30.0
-        elseif(13000 < zlay(k) .and. zlay(k) < 20000) then
-          u_rico(k)=30.0 - (30.0) /                                        &
-     & (20000 - 13000) * (zlay(k) - 13000)
-        else
-          u_rico(k)=0.0
-        endif
-
-!Q_v
-        if(0 < zlay(k) .and. zlay(k) < 740) then
-          q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)
-        elseif(740 < zlay(k) .and. zlay(k) < 3260) then
-          q_rico(k)=13.8 + (2.4 - 13.8) /                                   &
-     &          (3260 - 740) * (zlay(k) - 740)
-        elseif(3260 < zlay(k) .and. zlay(k) < 4000) then
-          q_rico(k)=2.4 + (1.8 - 2.4) /                                    &
-     &               (4000 - 3260) * (zlay(k) - 3260)
-        elseif(4000 < zlay(k) .and. zlay(k) < 9000) then
-          q_rico(k)=1.8 + (0 - 1.8) /                                      &
-     &             (9000 - 4000) * (zlay(k) - 4000)
-        else
-          q_rico(k)=0.0
-        endif
-
-!T
-        if(0 < zlay(k) .and. zlay(k) < 740) then
-          t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)
-        elseif(740 < zlay(k) .and. zlay(k) < 4000) then
-          t_rico(k)=292.0 + (278.0 - 292.0) /                              &                       
-     &       (4000 - 740) * (zlay(k) - 740)
-        elseif(4000 < zlay(k) .and. zlay(k) < 15000) then
-          t_rico(k)=278.0 + (203.0 - 278.0) /                              &
-     &       (15000 - 4000) * (zlay(k) - 4000)
-        elseif(15000 < zlay(k) .and. zlay(k) < 17500) then
-          t_rico(k)=203.0 + (194.0 - 203.0) /                              & 
-     &       (17500 - 15000)* (zlay(k) - 15000)
-        elseif(17500 < zlay(k) .and. zlay(k) < 20000) then
-          t_rico(k)=194.0 + (206.0 - 194.0) /                              &
-     &       (20000 - 17500)* (zlay(k) - 17500)
-        elseif(20000 < zlay(k) .and. zlay(k) < 60000) then
-          t_rico(k)=206.0 + (270.0 - 206.0) /                              & 
-     &        (60000 - 20000)* (zlay(k) - 20000)
-        endif
-
-! W
-        if(0 < zlay(k) .and. zlay(k) < 2260 ) then
-          w_rico(k)=- (0.005/2260) * zlay(k)
-        elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then
-          w_rico(k)=- 0.005
-        elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then
-       w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)
-        else
-          w_rico(k)=0.0
-        endif
-
-! dThrz+dTsw0+dTlw0
-        if(0 < zlay(k) .and. zlay(k) < 4000) then
-          dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/                     &
-     &               (86400*4000) * zlay(k)
-        elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
-          dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) /                           &
-     &           (86400*(5000 - 4000)) * (zlay(k) - 4000)
-        else
-          dth_dyn(k)=0.0
-        endif
-! dQhrz
-        if(0 < zlay(k) .and. zlay(k) < 3000) then
-          dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/                         &
-     &                    (86400*3000) * (zlay(k))
-        elseif(3000 < zlay(k) .and. zlay(k) < 4000) then
-          dqh_dyn(k)=0.345 / 86400
-        elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
-          dqh_dyn(k)=0.345 / 86400 +                                       &
-     &   (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)
-        else
-          dqh_dyn(k)=0.0
-        endif
-
-!?        if(play(k)>6e4) then
-!?          ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)
-!?        elseif((play(k)>3e4).and.(play(k)<6e4)) then
-!?          ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&
-!?                          *(6e4-play(k))/(6e4-3e4)
-!?        else
-!?          ratqs0(1,k)=ratqshaut
-!?        endif
-
-      enddo
-
-      do k=1,llm
-      q_rico(k)=q_rico(k)/1e3 
-      dqh_dyn(k)=dqh_dyn(k)/1e3
-      v_rico(k)=-3.8
-      enddo
-
-          return
-          end
-
-!======================================================================
-        SUBROUTINE interp_sandu_time(day,day1,annee_ref                    &
-     &             ,year_ini_sandu,day_ini_sandu,nt_sandu,dt_sandu         &
-     &             ,nlev_sandu,ts_sandu,ts_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_sandu: total nb of data in the forcing (e.g. 13 for Sanduref)
-! dt_sandu: total time interval (in sec) between 2 forcing data (e.g. 6h for Sanduref)
-!---------------------------------------------------------------------------------------
-! inputs:
-        integer annee_ref
-        integer nt_sandu,nlev_sandu
-        integer year_ini_sandu
-        real day, day1,day_ini_sandu,dt_sandu
-        real ts_sandu(nt_sandu)
-! outputs:
-        real ts_prof
-! local:
-        integer it_sandu1, it_sandu2
-        real timeit,time_sandu1,time_sandu2,frac
-! Check that initial day of the simulation consistent with SANDU period:
-       if (annee_ref.ne.2006 ) then
-        print*,'Pour SANDUREF, annee_ref doit etre 2006 '
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-!      if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then
-!       print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'
-!       print*,'Changer dayref dans run.def'
-!       stop
-!      endif
-
-! Determine timestep relative to the 1st day of TOGA-COARE:
-!       timeit=(day-day1)*86400.
-!       if (annee_ref.eq.1992) then
-!        timeit=(day-day_ini_sandu)*86400.
-!       else
-!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-!       endif
-      timeit=(day-day_ini_sandu)*86400
-
-! Determine the closest observation times:
-       it_sandu1=INT(timeit/dt_sandu)+1
-       it_sandu2=it_sandu1 + 1
-       time_sandu1=(it_sandu1-1)*dt_sandu
-       time_sandu2=(it_sandu2-1)*dt_sandu
-       print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu
-       print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2',              &
-     &          it_sandu1,it_sandu2,time_sandu1,time_sandu2
-
-       if (it_sandu1 .ge. nt_sandu) then
-        write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: '          &
-     &        ,day,it_sandu1,it_sandu2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       frac=(time_sandu2-timeit)/(time_sandu2-time_sandu1)
-       frac=max(frac,0.0)
-
-       ts_prof = ts_sandu(it_sandu2)                                       &
-     &          -frac*(ts_sandu(it_sandu2)-ts_sandu(it_sandu1))
-
-         print*,                                                           &
-     &'day,annee_ref,day_ini_sandu,timeit,it_sandu1,it_sandu2,SST:',       &
-     &day,annee_ref,day_ini_sandu,timeit/86400.,it_sandu1,                  &
-     &it_sandu2,ts_prof
-
-        return
-        END
-!=====================================================================
-!-------------------------------------------------------------------------
-      SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu,                &
-     & sens,flat,adv_theta,rad_theta,adv_qt)
-      implicit none
-
-!-------------------------------------------------------------------------
-! Read ARM_CU case forcing data
-!-------------------------------------------------------------------------
-
-      integer nlev_armcu,nt_armcu
-      real sens(nt_armcu),flat(nt_armcu)
-      real adv_theta(nt_armcu),rad_theta(nt_armcu),adv_qt(nt_armcu)
-      character*80 fich_armcu
-
-      integer ip
-
-      integer iy,im,id,ih,in
-
-      print*,'nlev_armcu',nlev_armcu
-
-      open(21,file=trim(fich_armcu),form='formatted')
-      read(21,'(a)')
-      do ip = 1, nt_armcu
-      read(21,'(a)')
-      read(21,'(a)')
-      read(21,223) iy, im, id, ih, in, sens(ip),flat(ip),                  &
-     &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
-      print *,'forcages=',iy,im,id,ih,in, sens(ip),flat(ip),               &
-     &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
-      enddo
-      close(21)
-
-  223 format(5i3,5f8.3)
-
-          return
-          end
-
-!=====================================================================
-       SUBROUTINE interp_toga_vertical(play,nlev_toga,plev_prof            &
-     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                         &
-     &         ,ht_prof,vt_prof,hq_prof,vq_prof                            &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                              &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
- 
-       implicit none
- 
-#include "dimensions.h"
-
-!-------------------------------------------------------------------------
-! Vertical interpolation of TOGA-COARE forcing data onto model levels
-!-------------------------------------------------------------------------
- 
-       integer nlevmax
-       parameter (nlevmax=41)
-       integer nlev_toga,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_prof(nlev_toga) 
-       real t_prof(nlev_toga),q_prof(nlev_toga)
-       real u_prof(nlev_toga),v_prof(nlev_toga), w_prof(nlev_toga)
-       real ht_prof(nlev_toga),vt_prof(nlev_toga)
-       real hq_prof(nlev_toga),vq_prof(nlev_toga)
- 
-       real t_mod(llm),q_mod(llm)
-       real u_mod(llm),v_mod(llm), w_mod(llm)
-       real ht_mod(llm),vt_mod(llm)
-       real hq_mod(llm),vq_mod(llm)
- 
-       integer l,k,k1,k2
-       real frac,frac1,frac2,fact
- 
-       do l = 1, llm
-
-        if (play(l).ge.plev_prof(nlev_toga)) then
- 
-        mxcalc=l
-         k1=0
-         k2=0
-
-         if (play(l).le.plev_prof(1)) then
-
-         do k = 1, nlev_toga-1
-          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_toga-1
-          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
-         enddo
-         endif
-
-         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
-         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
-         q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
-         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
-         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
-         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
-         ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
-         vt_mod(l)= vt_prof(k2) - frac*(vt_prof(k2)-vt_prof(k1))
-         hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
-         vq_mod(l)= vq_prof(k2) - frac*(vq_prof(k2)-vq_prof(k1))
-     
-         else !play>plev_prof(1)
-
-         k1=1
-         k2=2
-         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
-         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
-         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
-         q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
-         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
-         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
-         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
-         ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
-         vt_mod(l)= frac1*vt_prof(k1) - frac2*vt_prof(k2)
-         hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
-         vq_mod(l)= frac1*vq_prof(k1) - frac2*vq_prof(k2)
-
-         endif ! play.le.plev_prof(1)
-
-        else ! above max altitude of forcing file
- 
-!jyg
-         fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg
-         fact = max(fact,0.)                                           !jyg
-         fact = exp(-fact)                                             !jyg
-         t_mod(l)= t_prof(nlev_toga)                                   !jyg
-         q_mod(l)= q_prof(nlev_toga)*fact                              !jyg
-         u_mod(l)= u_prof(nlev_toga)*fact                              !jyg
-         v_mod(l)= v_prof(nlev_toga)*fact                              !jyg
-         w_mod(l)= 0.0                                                 !jyg
-         ht_mod(l)= ht_prof(nlev_toga)                                 !jyg
-         vt_mod(l)= vt_prof(nlev_toga)                                 !jyg
-         hq_mod(l)= hq_prof(nlev_toga)*fact                            !jyg
-         vq_mod(l)= vq_prof(nlev_toga)*fact                            !jyg
- 
-        endif ! play
- 
-       enddo ! l
-
-!       do l = 1,llm
-!       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
-!     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
-!       enddo
- 
-          return
-          end
- 
-!=====================================================================
-       SUBROUTINE interp_case_vertical(play,nlev_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                            &
-     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
- 
-       implicit none
- 
-#include "dimensions.h"
-
-!-------------------------------------------------------------------------
-! Vertical interpolation of TOGA-COARE 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_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), 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),dtrad_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),q_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)
-       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 dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)
- 
-       integer l,k,k1,k2
-       real frac,frac1,frac2,fact
- 
-       do l = 1, llm
-
-        if (play(l).ge.plev_prof_cas(nlev_cas)) then
- 
-        mxcalc=l
-         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))
-         q_mod_cas(l)= q_prof_cas(k2) - frac*(q_prof_cas(k2)-q_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))
-         w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_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))
-         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))
-     
-         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))
-         t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)
-         q_mod_cas(l)= frac1*q_prof_cas(k1) - frac2*q_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)
-         w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_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)
-         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)
-
-         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
-         q_mod_cas(l)= q_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)*fact                              !jyg
-         vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact                              !jyg
-         w_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
-         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
- 
-        endif ! play
- 
-       enddo ! l
-
-!       do l = 1,llm
-!       print *,'t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l) ',
-!     $        l,t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l)
-!       enddo
- 
-          return
-          end
-!***************************************************************************** 
-!=====================================================================
-       SUBROUTINE interp_dice_vertical(play,nlev_dice,nt_dice,plev_prof   &
-     &         ,th_prof,qv_prof,u_prof,v_prof,o3_prof                     &
-     &         ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof         &
-     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                          &
-     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
- 
-       implicit none
- 
-#include "dimensions.h"
-
-!-------------------------------------------------------------------------
-! Vertical interpolation of Dice forcing data onto model levels
-!-------------------------------------------------------------------------
- 
-       integer nlevmax
-       parameter (nlevmax=41)
-       integer nlev_dice,mxcalc,nt_dice
- 
-       real play(llm), plev_prof(nlev_dice) 
-       real th_prof(nlev_dice),qv_prof(nlev_dice)
-       real u_prof(nlev_dice),v_prof(nlev_dice) 
-       real o3_prof(nlev_dice)
-       real ht_prof(nlev_dice),hq_prof(nlev_dice)
-       real hu_prof(nlev_dice),hv_prof(nlev_dice)
-       real w_prof(nlev_dice),omega_prof(nlev_dice)
- 
-       real th_mod(llm),qv_mod(llm)
-       real u_mod(llm),v_mod(llm), o3_mod(llm)
-       real ht_mod(llm),hq_mod(llm)
-       real hu_mod(llm),hv_mod(llm),w_mod(llm),omega_mod(llm)
- 
-       integer l,k,k1,k2,kp
-       real aa,frac,frac1,frac2,fact
- 
-       do l = 1, llm
-
-        if (play(l).ge.plev_prof(nlev_dice)) then
- 
-        mxcalc=l
-         k1=0
-         k2=0
-
-         if (play(l).le.plev_prof(1)) then
-
-         do k = 1, nlev_dice-1
-          if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(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_dice-1
-          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
-         enddo
-         endif
-
-         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
-         th_mod(l)= th_prof(k2) - frac*(th_prof(k2)-th_prof(k1))
-         qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
-         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
-         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
-         o3_mod(l)= o3_prof(k2) - frac*(o3_prof(k2)-o3_prof(k1))
-         ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
-         hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
-         hu_mod(l)= hu_prof(k2) - frac*(hu_prof(k2)-hu_prof(k1))
-         hv_mod(l)= hv_prof(k2) - frac*(hv_prof(k2)-hv_prof(k1))
-         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
-         omega_mod(l)= omega_prof(k2) - frac*(omega_prof(k2)-omega_prof(k1))
-     
-         else !play>plev_prof(1)
-
-         k1=1
-         k2=2
-         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
-         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
-         th_mod(l)= frac1*th_prof(k1) - frac2*th_prof(k2)
-         qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
-         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
-         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
-         o3_mod(l)= frac1*o3_prof(k1) - frac2*o3_prof(k2)
-         ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
-         hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
-         hu_mod(l)= frac1*hu_prof(k1) - frac2*hu_prof(k2)
-         hv_mod(l)= frac1*hv_prof(k1) - frac2*hv_prof(k2)
-         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
-         omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
-
-         endif ! play.le.plev_prof(1)
-
-        else ! above max altitude of forcing file
- 
-!jyg
-         fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg
-         fact = max(fact,0.)                                           !jyg
-         fact = exp(-fact)                                             !jyg
-         th_mod(l)= th_prof(nlev_dice)                                 !jyg
-         qv_mod(l)= qv_prof(nlev_dice)*fact                            !jyg
-         u_mod(l)= u_prof(nlev_dice)*fact                              !jyg
-         v_mod(l)= v_prof(nlev_dice)*fact                              !jyg
-         o3_mod(l)= o3_prof(nlev_dice)*fact                            !jyg
-         ht_mod(l)= ht_prof(nlev_dice)                                 !jyg
-         hq_mod(l)= hq_prof(nlev_dice)*fact                            !jyg
-         hu_mod(l)= hu_prof(nlev_dice)                                 !jyg
-         hv_mod(l)= hv_prof(nlev_dice)                                 !jyg
-         w_mod(l)= 0.                                                  !jyg
-         omega_mod(l)= 0.                                              !jyg
- 
-        endif ! play
- 
-       enddo ! l
-
-!       do l = 1,llm
-!       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
-!     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
-!       enddo
- 
-          return
-          end
-
-!======================================================================
-        SUBROUTINE interp_astex_time(day,day1,annee_ref                    &
-     &             ,year_ini_astex,day_ini_astex,nt_astex,dt_astex         &
-     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex        &
-     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof   &
-     &             ,ufa_prof,vfa_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_astex: total nb of data in the forcing (e.g. 41 for Astex)
-! dt_astex: total time interval (in sec) between 2 forcing data (e.g. 1h for Astex)
-!---------------------------------------------------------------------------------------
-
-! inputs:
-        integer annee_ref
-        integer nt_astex,nlev_astex
-        integer year_ini_astex
-        real day, day1,day_ini_astex,dt_astex
-        real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
-        real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
-! outputs:
-        real div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
-! local:
-        integer it_astex1, it_astex2
-        real timeit,time_astex1,time_astex2,frac
-
-! Check that initial day of the simulation consistent with ASTEX period:
-       if (annee_ref.ne.1992 ) then
-        print*,'Pour Astex, annee_ref doit etre 1992 '
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then
-        print*,'Astex debute le 13 Juin 1992 (jour julien=165)'
-        print*,'Changer dayref dans run.def'
-        stop
-       endif
-
-! Determine timestep relative to the 1st day of TOGA-COARE:
-!       timeit=(day-day1)*86400.
-!       if (annee_ref.eq.1992) then
-!        timeit=(day-day_ini_astex)*86400.
-!       else
-!        timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 1992
-!       endif
-      timeit=(day-day_ini_astex)*86400
-
-! Determine the closest observation times:
-       it_astex1=INT(timeit/dt_astex)+1
-       it_astex2=it_astex1 + 1
-       time_astex1=(it_astex1-1)*dt_astex
-       time_astex2=(it_astex2-1)*dt_astex
-       print *,'timeit day day_ini_astex',timeit,day,day_ini_astex
-       print *,'it_astex1,it_astex2,time_astex1,time_astex2',              &
-     &          it_astex1,it_astex2,time_astex1,time_astex2
-
-       if (it_astex1 .ge. nt_astex) then
-        write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: '          &
-     &        ,day,it_astex1,it_astex2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       frac=(time_astex2-timeit)/(time_astex2-time_astex1)
-       frac=max(frac,0.0)
-
-       div_prof = div_astex(it_astex2)                                     &
-     &          -frac*(div_astex(it_astex2)-div_astex(it_astex1))
-       ts_prof = ts_astex(it_astex2)                                        &
-     &          -frac*(ts_astex(it_astex2)-ts_astex(it_astex1))
-       ug_prof = ug_astex(it_astex2)                                       &
-     &          -frac*(ug_astex(it_astex2)-ug_astex(it_astex1))
-       vg_prof = vg_astex(it_astex2)                                       &
-     &          -frac*(vg_astex(it_astex2)-vg_astex(it_astex1))
-       ufa_prof = ufa_astex(it_astex2)                                     &
-     &          -frac*(ufa_astex(it_astex2)-ufa_astex(it_astex1))
-       vfa_prof = vfa_astex(it_astex2)                                     &
-     &          -frac*(vfa_astex(it_astex2)-vfa_astex(it_astex1))
-
-         print*,                                                           &
-     &'day,annee_ref,day_ini_astex,timeit,it_astex1,it_astex2,SST:',       &
-     &day,annee_ref,day_ini_astex,timeit/86400.,it_astex1,                 &
-     &it_astex2,div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof 
-
-        return
-        END
-
-!======================================================================
-        SUBROUTINE interp_toga_time(day,day1,annee_ref                     &
-     &             ,year_ini_toga,day_ini_toga,nt_toga,dt_toga,nlev_toga   &
-     &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga   &
-     &             ,ht_toga,vt_toga,hq_toga,vq_toga                        &
-     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof   &
-     &             ,ht_prof,vt_prof,hq_prof,vq_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_toga: total nb of data in the forcing (e.g. 480 for TOGA-COARE)
-! dt_toga: total time interval (in sec) between 2 forcing data (e.g. 6h for TOGA-COARE)
-!---------------------------------------------------------------------------------------
-
-#include "compar1d.h"
-
-! inputs:
-        integer annee_ref
-        integer nt_toga,nlev_toga
-        integer year_ini_toga
-        real day, day1,day_ini_toga,dt_toga
-        real ts_toga(nt_toga)
-        real plev_toga(nlev_toga,nt_toga),t_toga(nlev_toga,nt_toga)
-        real q_toga(nlev_toga,nt_toga),u_toga(nlev_toga,nt_toga)
-        real v_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)
-        real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
-        real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
-! outputs:
-        real ts_prof
-        real plev_prof(nlev_toga),t_prof(nlev_toga)
-        real q_prof(nlev_toga),u_prof(nlev_toga)
-        real v_prof(nlev_toga),w_prof(nlev_toga)
-        real ht_prof(nlev_toga),vt_prof(nlev_toga)
-        real hq_prof(nlev_toga),vq_prof(nlev_toga)
-! local:
-        integer it_toga1, it_toga2,k
-        real timeit,time_toga1,time_toga2,frac
-
-
-        if (forcing_type.eq.2) then
-! Check that initial day of the simulation consistent with TOGA-COARE period:
-       if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then
-        print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then
-        print*,'TOGA-COARE a débuté le 1er Nov 1992 (jour julien=306)'
-        print*,'Changer dayref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then
-        print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'
-        print*,'Changer dayref ou nday dans run.def'
-        stop
-       endif
-
-       else if (forcing_type.eq.4) then
-
-! Check that initial day of the simulation consistent with TWP-ICE period:
-       if (annee_ref.ne.2006) then
-        print*,'Pour TWP-ICE, annee_ref doit etre 2006'
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then
-        print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'
-        print*,'Changer dayref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then
-        print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'
-        print*,'Changer dayref ou nday dans run.def'
-        stop
-       endif
-
-       endif
-
-! Determine timestep relative to the 1st day of TOGA-COARE:
-!       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_toga)*86400
-
-! Determine the closest observation times:
-       it_toga1=INT(timeit/dt_toga)+1
-       it_toga2=it_toga1 + 1
-       time_toga1=(it_toga1-1)*dt_toga
-       time_toga2=(it_toga2-1)*dt_toga
-
-       if (it_toga1 .ge. nt_toga) then
-        write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: '            &
-     &        ,day,it_toga1,it_toga2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       frac=(time_toga2-timeit)/(time_toga2-time_toga1)
-       frac=max(frac,0.0)
-
-       ts_prof = ts_toga(it_toga2)                                         &
-     &          -frac*(ts_toga(it_toga2)-ts_toga(it_toga1))
-
-!        print*,
-!     :'day,annee_ref,day_ini_toga,timeit,it_toga1,it_toga2,SST:',
-!     :day,annee_ref,day_ini_toga,timeit/86400.,it_toga1,it_toga2,ts_prof
-
-       do k=1,nlev_toga
-        plev_prof(k) = 100.*(plev_toga(k,it_toga2)                         &
-     &          -frac*(plev_toga(k,it_toga2)-plev_toga(k,it_toga1)))
-        t_prof(k) = t_toga(k,it_toga2)                                     &
-     &          -frac*(t_toga(k,it_toga2)-t_toga(k,it_toga1))
-        q_prof(k) = q_toga(k,it_toga2)                                     &
-     &          -frac*(q_toga(k,it_toga2)-q_toga(k,it_toga1))
-        u_prof(k) = u_toga(k,it_toga2)                                     &
-     &          -frac*(u_toga(k,it_toga2)-u_toga(k,it_toga1))
-        v_prof(k) = v_toga(k,it_toga2)                                     &
-     &          -frac*(v_toga(k,it_toga2)-v_toga(k,it_toga1))
-        w_prof(k) = w_toga(k,it_toga2)                                     &
-     &          -frac*(w_toga(k,it_toga2)-w_toga(k,it_toga1))
-        ht_prof(k) = ht_toga(k,it_toga2)                                   &
-     &          -frac*(ht_toga(k,it_toga2)-ht_toga(k,it_toga1))
-        vt_prof(k) = vt_toga(k,it_toga2)                                   &
-     &          -frac*(vt_toga(k,it_toga2)-vt_toga(k,it_toga1))
-        hq_prof(k) = hq_toga(k,it_toga2)                                   &
-     &          -frac*(hq_toga(k,it_toga2)-hq_toga(k,it_toga1))
-        vq_prof(k) = vq_toga(k,it_toga2)                                   &
-     &          -frac*(vq_toga(k,it_toga2)-vq_toga(k,it_toga1))
-        enddo
-
-        return
-        END
-
-!======================================================================
-        SUBROUTINE interp_dice_time(day,day1,annee_ref                    &
-     &             ,year_ini_dice,day_ini_dice,nt_dice,dt_dice            &
-     &             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice       &
-     &             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice         &
-     &             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice     &
-     &             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof         &
-     &             ,ustar_prof,psurf_prof,ug_prof,vg_prof                 &
-     &             ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_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_dice: total nb of data in the forcing (e.g. 145 for Dice)
-! dt_dice: total time interval (in sec) between 2 forcing data (e.g. 30min. for Dice)
-!---------------------------------------------------------------------------------------
-
-#include "compar1d.h"
-
-! inputs:
-        integer annee_ref
-        integer nt_dice,nlev_dice
-        integer year_ini_dice
-        real day, day1,day_ini_dice,dt_dice
-        real shf_dice(nt_dice),lhf_dice(nt_dice),lwup_dice(nt_dice)
-        real swup_dice(nt_dice),tg_dice(nt_dice),ustar_dice(nt_dice)
-        real psurf_dice(nt_dice),ug_dice(nt_dice),vg_dice(nt_dice)
-        real ht_dice(nlev_dice,nt_dice),hq_dice(nlev_dice,nt_dice)
-        real hu_dice(nlev_dice,nt_dice),hv_dice(nlev_dice,nt_dice)
-        real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)
-! outputs:
-        real tg_prof,shf_prof,lhf_prof,lwup_prof,swup_prof
-        real ustar_prof,psurf_prof,ug_prof,vg_prof
-        real ht_prof(nlev_dice),hq_prof(nlev_dice)
-        real hu_prof(nlev_dice),hv_prof(nlev_dice)
-        real w_prof(nlev_dice),omega_prof(nlev_dice)
-! local:
-        integer it_dice1, it_dice2,k
-        real timeit,time_dice1,time_dice2,frac
-
-
-        if (forcing_type.eq.7) then
-! Check that initial day of the simulation consistent with Dice period:
-       print *,'annee_ref=',annee_ref
-       print *,'day1=',day1
-       print *,'day_ini_dice=',day_ini_dice
-       if (annee_ref.ne.1999) then
-        print*,'Pour Dice, annee_ref doit etre 1999'
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then
-        print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'
-        print*,'Changer dayref dans run.def',day1,day_ini_dice
-        stop
-       endif
-       if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then
-        print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'
-        print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice
-        stop
-       endif
-
-       endif
-
-! Determine timestep relative to the 1st day of TOGA-COARE:
-!       timeit=(day-day1)*86400.
-!       if (annee_ref.eq.1992) then
-!        timeit=(day-day_ini_dice)*86400.
-!       else
-!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-!       endif
-      timeit=(day-day_ini_dice)*86400
-
-! Determine the closest observation times:
-       it_dice1=INT(timeit/dt_dice)+1
-       it_dice2=it_dice1 + 1
-       time_dice1=(it_dice1-1)*dt_dice
-       time_dice2=(it_dice2-1)*dt_dice
-
-       if (it_dice1 .ge. nt_dice) then
-        write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       frac=(time_dice2-timeit)/(time_dice2-time_dice1)
-       frac=max(frac,0.0)
-
-       shf_prof = shf_dice(it_dice2)-frac*(shf_dice(it_dice2)-shf_dice(it_dice1))
-       lhf_prof = lhf_dice(it_dice2)-frac*(lhf_dice(it_dice2)-lhf_dice(it_dice1))
-       lwup_prof = lwup_dice(it_dice2)-frac*(lwup_dice(it_dice2)-lwup_dice(it_dice1))
-       swup_prof = swup_dice(it_dice2)-frac*(swup_dice(it_dice2)-swup_dice(it_dice1))
-       tg_prof = tg_dice(it_dice2)-frac*(tg_dice(it_dice2)-tg_dice(it_dice1))
-       ustar_prof = ustar_dice(it_dice2)-frac*(ustar_dice(it_dice2)-ustar_dice(it_dice1))
-       psurf_prof = psurf_dice(it_dice2)-frac*(psurf_dice(it_dice2)-psurf_dice(it_dice1))
-       ug_prof = ug_dice(it_dice2)-frac*(ug_dice(it_dice2)-ug_dice(it_dice1))
-       vg_prof = vg_dice(it_dice2)-frac*(vg_dice(it_dice2)-vg_dice(it_dice1))
-
-!        print*,
-!     :'day,annee_ref,day_ini_dice,timeit,it_dice1,it_dice2,SST:',
-!     :day,annee_ref,day_ini_dice,timeit/86400.,it_dice1,it_dice2,ts_prof
-
-       do k=1,nlev_dice
-        ht_prof(k) = ht_dice(k,it_dice2)-frac*(ht_dice(k,it_dice2)-ht_dice(k,it_dice1))
-        hq_prof(k) = hq_dice(k,it_dice2)-frac*(hq_dice(k,it_dice2)-hq_dice(k,it_dice1))
-        hu_prof(k) = hu_dice(k,it_dice2)-frac*(hu_dice(k,it_dice2)-hu_dice(k,it_dice1))
-        hv_prof(k) = hv_dice(k,it_dice2)-frac*(hv_dice(k,it_dice2)-hv_dice(k,it_dice1))
-        w_prof(k) = w_dice(k,it_dice2)-frac*(w_dice(k,it_dice2)-w_dice(k,it_dice1))
-        omega_prof(k) = omega_dice(k,it_dice2)-frac*(omega_dice(k,it_dice2)-omega_dice(k,it_dice1))
-        enddo
-
-        return
-        END
-
-!======================================================================
-        SUBROUTINE interp_armcu_time(day,day1,annee_ref                    &
-     &             ,year_ini_armcu,day_ini_armcu,nt_armcu,dt_armcu         &
-     &             ,nlev_armcu,fs_armcu,fl_armcu,at_armcu,rt_armcu         &
-     &             ,aqt_armcu,fs_prof,fl_prof,at_prof,rt_prof,aqt_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_armcu: total nb of data in the forcing (e.g. 31 for armcu)
-! dt_armcu: total time interval (in sec) between 2 forcing data (e.g. 1/2h for armcu)
-! fs= sensible flux
-! fl= latent flux
-! at,rt,aqt= advective and radiative tendencies
-!---------------------------------------------------------------------------------------
-
-! inputs:
-        integer annee_ref
-        integer nt_armcu,nlev_armcu
-        integer year_ini_armcu
-        real day, day1,day_ini_armcu,dt_armcu
-        real fs_armcu(nt_armcu),fl_armcu(nt_armcu),at_armcu(nt_armcu)
-        real rt_armcu(nt_armcu),aqt_armcu(nt_armcu)
-! outputs:
-        real fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
-! local:
-        integer it_armcu1, it_armcu2,k
-        real timeit,time_armcu1,time_armcu2,frac
-
-! Check that initial day of the simulation consistent with ARMCU period:
-       if (annee_ref.ne.1997 ) then
-        print*,'Pour ARMCU, annee_ref doit etre 1997 '
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-
-      timeit=(day-day_ini_armcu)*86400
-
-! Determine the closest observation times:
-       it_armcu1=INT(timeit/dt_armcu)+1
-       it_armcu2=it_armcu1 + 1
-       time_armcu1=(it_armcu1-1)*dt_armcu
-       time_armcu2=(it_armcu2-1)*dt_armcu
-       print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu
-       print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2',              &
-     &          it_armcu1,it_armcu2,time_armcu1,time_armcu2
-
-       if (it_armcu1 .ge. nt_armcu) then
-        write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: '          &
-     &        ,day,it_armcu1,it_armcu2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       frac=(time_armcu2-timeit)/(time_armcu2-time_armcu1)
-       frac=max(frac,0.0)
-
-       fs_prof = fs_armcu(it_armcu2)                                       &
-     &          -frac*(fs_armcu(it_armcu2)-fs_armcu(it_armcu1))
-       fl_prof = fl_armcu(it_armcu2)                                       &
-     &          -frac*(fl_armcu(it_armcu2)-fl_armcu(it_armcu1))
-       at_prof = at_armcu(it_armcu2)                                       &
-     &          -frac*(at_armcu(it_armcu2)-at_armcu(it_armcu1))
-       rt_prof = rt_armcu(it_armcu2)                                       &
-     &          -frac*(rt_armcu(it_armcu2)-rt_armcu(it_armcu1))
-       aqt_prof = aqt_armcu(it_armcu2)                                       &
-     &          -frac*(aqt_armcu(it_armcu2)-aqt_armcu(it_armcu1))
-
-         print*,                                                           &
-     &'day,annee_ref,day_ini_armcu,timeit,it_armcu1,it_armcu2,SST:',       &
-     &day,annee_ref,day_ini_armcu,timeit/86400.,it_armcu1,                 &
-     &it_armcu2,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
-
-        return
-        END
-
-!=====================================================================
-      subroutine readprofiles(nlev_max,kmax,ntrac,height,                  &
-     &           thlprof,qtprof,uprof,                                     &
-     &           vprof,e12prof,ugprof,vgprof,                              &
-     &           wfls,dqtdxls,dqtdyls,dqtdtls,                             &
-     &           thlpcar,tracer,nt1,nt2)
-      implicit none
-
-        integer nlev_max,kmax,kmax2,ntrac
-        logical :: llesread = .true.
-
-        real height(nlev_max),thlprof(nlev_max),qtprof(nlev_max),          &
-     &       uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max),            &
-     &       ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max),             &
-     &       dqtdxls(nlev_max),dqtdyls(nlev_max),dqtdtls(nlev_max),        &
-     &           thlpcar(nlev_max),tracer(nlev_max,ntrac)
-
-        integer, parameter :: ilesfile=1
-        integer :: ierr,k,itrac,nt1,nt2
-
-        if(.not.(llesread)) return
-
-       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
-        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
-        read (ilesfile,*) kmax
-        do k=1,kmax
-          read (ilesfile,*) height(k),thlprof(k),qtprof (k),               &
-     &                      uprof (k),vprof  (k),e12prof(k)
-        enddo
-        close(ilesfile)
-
-       open(ilesfile,file='lscale.inp.001',status='old',iostat=ierr)
-        if (ierr /= 0) stop 'ERROR:Lscale.inp does not exist'
-        read (ilesfile,*) kmax2
-        if (kmax .ne. kmax2) then
-          print *, 'fichiers prof.inp et lscale.inp incompatibles :'
-          print *, 'nbre de niveaux : ',kmax,' et ',kmax2
-          stop 'lecture profiles'
-        endif
-        do k=1,kmax
-          read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k),         &
-     &                      dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)
-        end do
-        close(ilesfile)
-
-       open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)
-        if (ierr /= 0) then
-            print*,'WARNING : trac.inp does not exist'
-        else
-        read (ilesfile,*) kmax2,nt1,nt2
-        if (nt2>ntrac) then
-          stop'Augmenter le nombre de traceurs dans traceur.def'
-        endif
-        if (kmax .ne. kmax2) then
-          print *, 'fichiers prof.inp et lscale.inp incompatibles :'
-          print *, 'nbre de niveaux : ',kmax,' et ',kmax2
-          stop 'lecture profiles'
-        endif
-        do k=1,kmax
-          read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)
-        end do
-        close(ilesfile)
-        endif
-
-        return
-        end
-!======================================================================
-      subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof,       &
-     &       thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)
-!======================================================================
-      implicit none
-
-        integer nlev_max,kmax
-        logical :: llesread = .true.
-
-        real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
-        real thlprof(nlev_max)
-        real qprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
-        real wprof(nlev_max),omega(nlev_max),o3mmr(nlev_max)
-
-        integer, parameter :: ilesfile=1
-        integer :: k,ierr
-
-        if(.not.(llesread)) return
-
-       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
-        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
-        read (ilesfile,*) kmax
-        do k=1,kmax
-          read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
-     &                      qprof (k),uprof(k),  vprof(k),  wprof(k),      &
-     &                      omega (k),o3mmr(k)
-        enddo
-        close(ilesfile)
-
-        return
-        end
-
-!======================================================================
-      subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof,       &
-     &    thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)
-!======================================================================
-      implicit none
-
-        integer nlev_max,kmax
-        logical :: llesread = .true.
-
-        real height(nlev_max),pprof(nlev_max),tprof(nlev_max),             &
-     &  thlprof(nlev_max),qlprof(nlev_max),qtprof(nlev_max),               &
-     &  qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max),                  &
-     &  wprof(nlev_max),tkeprof(nlev_max),o3mmr(nlev_max)
-
-        integer, parameter :: ilesfile=1
-        integer :: ierr,k
-
-        if(.not.(llesread)) return
-
-       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
-        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
-        read (ilesfile,*) kmax
-        do k=1,kmax
-          read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
-     &                qvprof (k),qlprof (k),qtprof (k),                    &
-     &                uprof(k),  vprof(k),  wprof(k),tkeprof(k),o3mmr(k)
-        enddo
-        close(ilesfile)
-
-        return
-        end
-
-
-
-!======================================================================
-      subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof,       &
-     &       vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)
-!======================================================================
-      implicit none
-
-        integer nlev_max,kmax
-        logical :: llesread = .true.
-
-        real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
-        real thetaprof(nlev_max),rvprof(nlev_max)
-        real qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
-        real aprof(nlev_max+1),bprof(nlev_max+1)
-
-        integer, parameter :: ilesfile=1
-        integer, parameter :: ifile=2
-        integer :: ierr,jtot,k
-
-        if(.not.(llesread)) return
-
-! Read profiles at full levels
-       IF(nlev_max.EQ.19) THEN
-       open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)
-       print *,'On ouvre prof.inp.19'
-       ELSE
-       open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)
-       print *,'On ouvre prof.inp.40'
-       ENDIF
-        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
-        read (ilesfile,*) kmax
-        do k=1,kmax
-          read (ilesfile,*) height(k)    ,pprof(k),  uprof(k), vprof(k),   &
-     &                      thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)
-        enddo
-        close(ilesfile)
-
-! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf) 
-       IF(nlev_max.EQ.19) THEN
-       open (ifile,file='proh.inp.19',status='old',iostat=ierr)
-       print *,'On ouvre proh.inp.19'
-       if (ierr /= 0) stop 'ERROR:Proh.inp.19 does not exist'
-       ELSE
-       open (ifile,file='proh.inp.40',status='old',iostat=ierr)
-       print *,'On ouvre proh.inp.40'
-       if (ierr /= 0) stop 'ERROR:Proh.inp.40 does not exist'
-       ENDIF
-        read (ifile,*) kmax
-        do k=1,kmax
-          read (ifile,*) jtot,aprof(k),bprof(k)
-        enddo
-        close(ifile)
-
-        return
-        end
-
-!=====================================================================
-      subroutine read_fire(fich_fire,nlevel,ntime                          &
-     &     ,zz,thl,qt,u,v,tke                                              &
-     &     ,ug,vg,wls,dqtdx,dqtdy,dqtdt,thl_rad)
-
-!program reading forcings of the FIRE case study
-
-
-      implicit none
-
-#include "netcdf.inc"
-
-      integer ntime,nlevel
-      character*80 :: fich_fire
-      real*8 zz(nlevel)
-
-      real*8 thl(nlevel)
-      real*8 qt(nlevel),u(nlevel)
-      real*8 v(nlevel),tke(nlevel)
-      real*8 ug(nlevel,ntime),vg(nlevel,ntime),wls(nlevel,ntime)
-      real*8 dqtdx(nlevel,ntime),dqtdy(nlevel,ntime)
-      real*8 dqtdt(nlevel,ntime),thl_rad(nlevel,ntime)
-
-      integer nid, ierr
-      integer nbvar3d
-      parameter(nbvar3d=30)
-      integer var3didin(nbvar3d)
-
-      ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)
-      if (ierr.NE.NF_NOERR) then
-         write(*,*) 'ERROR: Pb opening forcings nc file '
-         write(*,*) NF_STRERROR(ierr)
-         stop ""
-      endif
-
-
-       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,"thetal",var3didin(2))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'temp'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"qt",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,"tke",var3didin(6))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'tke'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'ug'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vg'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"wls",var3didin(9))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'wls'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dqtdx'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dqtdy'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dqtdt'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'thl_rad'
-      endif
-!dimensions lecture
-!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture z ok',zz
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture thl ok',thl
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture qt ok',qt
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture u ok',u
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture v ok',v
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture tke ok',tke
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ug ok',ug
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vg ok',vg
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture wls ok',wls
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dqtdx ok',dqtdx
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dqtdy ok',dqtdy
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dqtdt ok',dqtdt
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture thl_rad ok',thl_rad
-
-         return 
-         end subroutine read_fire
-!=====================================================================
-      subroutine read_dice(fich_dice,nlevel,ntime                         &
-     &     ,zz,pres,th,qv,u,v,o3                                          &
-     &     ,shf,lhf,lwup,swup,tg,ustar,psurf,ug,vg                        &
-     &     ,hadvt,hadvq,hadvu,hadvv,w,omega)
-
-!program reading initial profils and forcings of the Dice case study
-
-
-      implicit none
-
-#include "netcdf.inc"
-
-      integer ntime,nlevel
-      integer l,k
-      character*80 :: fich_dice
-      real*8 time(ntime)
-      real*8 zz(nlevel)
-
-      real*8 th(nlevel),pres(nlevel)
-      real*8 qv(nlevel),u(nlevel),v(nlevel),o3(nlevel)
-      real*8 shf(ntime),lhf(ntime),lwup(ntime),swup(ntime),tg(ntime)
-      real*8 ustar(ntime),psurf(ntime),ug(ntime),vg(ntime)
-      real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime),hadvu(nlevel,ntime)
-      real*8 hadvv(nlevel,ntime),w(nlevel,ntime),omega(nlevel,ntime)
-
-      integer nid, ierr
-      integer nbvar3d
-      parameter(nbvar3d=30)
-      integer var3didin(nbvar3d)
-
-      ierr = NF_OPEN(fich_dice,NF_NOWRITE,nid)
-      if (ierr.NE.NF_NOERR) then
-         write(*,*) 'ERROR: Pb opening forcings nc file '
-         write(*,*) NF_STRERROR(ierr)
-         stop ""
-      endif
-
-
-       ierr=NF_INQ_VARID(nid,"height",var3didin(1)) 
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'height'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"pf",var3didin(11)) 
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'pf'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"theta",var3didin(12))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'theta'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"qv",var3didin(13))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'qv'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"u",var3didin(14))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'u'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"v",var3didin(15))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'o3'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"shf",var3didin(2))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'shf'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lhf'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lwup'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"swup",var3didin(5))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dqtdx'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'Tg'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'ustar'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'psurf'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'Ug'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'Vg'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hadvT'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hadvq'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hadvu'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hadvv'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"w",var3didin(21))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'w'
-      endif
-
-      ierr=NF_INQ_VARID(nid,"omega",var3didin(22))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'omega'
-      endif
-!dimensions lecture
-!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture zz ok',zz
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture pres ok',pres
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture th ok',th
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture qv ok',qv
- 
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture u ok',u
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture v ok',v
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture o3 ok',o3
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture shf ok',shf
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture lhf ok',lhf
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture lwup ok',lwup
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture swup ok',swup
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture tg ok',tg
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ustar ok',ustar
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture psurf ok',psurf
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ug ok',ug
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vg ok',vg
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hadvt ok',hadvt
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hadvq ok',hadvq
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hadvu ok',hadvu
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hadvv ok',hadvv
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture w ok',w
-
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)
-#else
-         ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)
-#endif
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture omega ok',omega
-
-         return 
-         end subroutine read_dice
-!=====================================================================
-!     Reads CIRC input files      
-
-      SUBROUTINE read_circ(nlev_circ,cf,lwp,iwp,reliq,reice,t,z,p,pm,h2o,o3,sza)
-      
-      parameter (ncm_1=49180)
-#include "YOMCST.h"
-
-      real albsfc(ncm_1), albsfc_w(ncm_1)
-      real cf(nlev_circ), icefra(nlev_circ), deice(nlev_circ), &
-           reliq(nlev_circ), reice(nlev_circ), lwp(nlev_circ), iwp(nlev_circ)
-      real t(nlev_circ+1), z(nlev_circ+1), dz(nlev_circ), p(nlev_circ+1)
-      real aer_beta(nlev_circ), waer(nlev_circ), gaer(nlev_circ)
-      real pm(nlev_circ), tm(nlev_circ), h2o(nlev_circ), o3(nlev_circ)
-      real co2(nlev_circ), n2o(nlev_circ), co(nlev_circ), ch4(nlev_circ), &
-           o2(nlev_circ), ccl4(nlev_circ), f11(nlev_circ), f12(nlev_circ)
-!     za= zenital angle
-!     sza= cosinus angle zenital
-      real wavn(ncm_1), ssf(ncm_1),za,sza
-      integer nlev
-
-
-!     Open the files
-
-      open (11, file='Tsfc_sza_nlev_case.txt', status='old')
-      open (12, file='level_input_case.txt', status='old')
-      open (13, file='layer_input_case.txt', status='old')
-      open (14, file='aerosol_input_case.txt', status='old')
-      open (15, file='cloud_input_case.txt', status='old')
-      open (16, file='sfcalbedo_input_case.txt', status='old')
-      
-!     Read scalar information
-      do iskip=1,5
-         read (11, *)
-      enddo
-      read (11, '(i8)') nlev
-      read (11, '(f10.2)') tsfc
-      read (11, '(f10.2)') za
-      read (11, '(f10.4)') sw_dn_toa
-      sza=cos(za/180.*RPI)
-      print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI
-      close(11)
-
-!     Read level information
-      read (12, *)
-      do il=1,nlev
-         read (12, 302) ilev, z(il), p(il), t(il)
-         z(il)=z(il)*1000.    ! z donne en km
-         p(il)=p(il)*100.     ! p donne en mb
-      enddo
-302   format (i8, f8.3, 2f9.2)
-      close(12)
-
-!     Read layer information (midpoint values)
-      do iskip=1,3
-         read (13, *)
-      enddo
-      do il=1,nlev-1
-         read (13, 303) ilev,pm(il),tm(il),h2o(il),co2(il),o3(il), &
-                        n2o(il),co(il),ch4(il),o2(il),ccl4(il), &
-                        f11(il),f12(il)
-         pm(il)=pm(il)*100.
-      enddo
-303   format (i8, 2f9.2, 10(2x,e13.7))      
-      close(13)
-      
-!     Read aerosol layer information
-      do iskip=1,3
-         read (14, *)
-      enddo
-      read (14, '(f10.2)') aer_alpha
-      read (14, *)
-      read (14, *)
-      do il=1,nlev-1
-         read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)
-      enddo
-304   format (i8, f9.5, 2f8.3)
-      close(14)
-      
-!     Read cloud information
-      do iskip=1,3
-         read (15, *)
-      enddo
-      do il=1,nlev-1
-         read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)
-         lwp(il)=lwp(il)/1000.          ! lwp donne en g/kg
-         iwp(il)=iwp(il)/1000.          ! iwp donne en g/kg
-         reliq(il)=reliq(il)/1000000.   ! reliq donne en microns
-         reice(il)=reice(il)/1000000.   ! reice donne en microns
-      enddo
-305   format (i8, f8.3, 4f9.2)
-      close(15)
-
-!     Read surface albedo (weighted & unweighted) and spectral solar irradiance
-      do iskip=1,6
-         read (16, *)
-      enddo
-      do icm_1=1,ncm_1
-         read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)
-      enddo
-306   format(f10.1, 2f12.5, f14.8)
-      close(16)
- 
-      return 
-      end subroutine read_circ
-!=====================================================================
-!     Reads RTMIP input files      
-
-      SUBROUTINE read_rtmip(nlev_rtmip,play,plev,t,h2o,o3)
-      
-#include "YOMCST.h"
-
-      real t(nlev_rtmip), pt(nlev_rtmip),pb(nlev_rtmip),h2o(nlev_rtmip), o3(nlev_rtmip)
-      real temp(nlev_rtmip), play(nlev_rtmip),ovap(nlev_rtmip), oz(nlev_rtmip),plev(nlev_rtmip+1)
-      integer nlev
-
-
-!     Open the files
-
-      open (11, file='low_resolution_profile.txt', status='old')
-      
-!     Read level information
-      read (11, *)
-      do il=1,nlev_rtmip
-         read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)
-      enddo
-      do il=1,nlev_rtmip
-         play(il)=pt(nlev_rtmip-il+1)*100.     ! p donne en mb
-         temp(il)=t(nlev_rtmip-il+1)
-         ovap(il)=h2o(nlev_rtmip-il+1)
-         oz(il)=o3(nlev_rtmip-il+1)
-      enddo
-      do il=1,39
-         plev(il)=play(il)+(play(il+1)-play(il))/2.
-         print *,'il p t ovap oz=',il,plev(il),temp(il),ovap(il),oz(il)
-      enddo
-      plev(41)=101300.
-302   format (e16.10,3x,e16.10,3x,e16.10,3x,e12.6,3x,e12.6)
-      close(12)
- 
-      return 
-      end subroutine read_rtmip
-!=====================================================================
-
-!  Subroutines for nudging
-
-      Subroutine Nudge_RHT_init (paprs,pplay,t,q,t_targ,rh_targ)
-! ========================================================
-  USE dimphy
-
-  implicit none
-
-! ========================================================
-      REAL paprs(klon,klevp1)
-      REAL pplay(klon,klev)
-!
-!      Variables d'etat
-      REAL t(klon,klev)
-      REAL q(klon,klev)
-!
-!   Profiles cible
-      REAL t_targ(klon,klev)
-      REAL rh_targ(klon,klev)
-!
-   INTEGER k,i
-   REAL zx_qs
-
-! Declaration des constantes et des fonctions thermodynamiques
-!
-include "YOMCST.h"
-include "YOETHF.h"
-!
-!  ----------------------------------------
-!  Statement functions
-include "FCTTRE.h"
-!  ----------------------------------------
-!
-        DO k = 1,klev
-         DO i = 1,klon
-           t_targ(i,k) = t(i,k)
-           IF (t(i,k).LT.RTT) THEN
-              zx_qs = qsats(t(i,k))/(pplay(i,k))
-           ELSE
-              zx_qs = qsatl(t(i,k))/(pplay(i,k))
-           ENDIF
-           rh_targ(i,k) = q(i,k)/zx_qs
-         ENDDO
-        ENDDO
-      print *, 't_targ',t_targ
-      print *, 'rh_targ',rh_targ
-!
-!
-      RETURN
-      END
-
-      Subroutine Nudge_UV_init (paprs,pplay,u,v,u_targ,v_targ)
-! ========================================================
-  USE dimphy
-
-  implicit none
-
-! ========================================================
-      REAL paprs(klon,klevp1)
-      REAL pplay(klon,klev)
-!
-!      Variables d'etat
-      REAL u(klon,klev)
-      REAL v(klon,klev)
-!
-!   Profiles cible
-      REAL u_targ(klon,klev)
-      REAL v_targ(klon,klev)
-!
-   INTEGER k,i
-!
-        DO k = 1,klev
-         DO i = 1,klon
-           u_targ(i,k) = u(i,k)
-           v_targ(i,k) = v(i,k)
-         ENDDO
-        ENDDO
-      print *, 'u_targ',u_targ
-      print *, 'v_targ',v_targ
-!
-!
-      RETURN
-      END
-
-      Subroutine Nudge_RHT (dtime,paprs,pplay,t_targ,rh_targ,t,q,          &
-     &                      d_t,d_q)
-! ========================================================
-  USE dimphy
-
-  implicit none
-
-! ========================================================
-      REAL dtime
-      REAL paprs(klon,klevp1)
-      REAL pplay(klon,klev)
-!
-!      Variables d'etat
-      REAL t(klon,klev)
-      REAL q(klon,klev)
-!
-! Tendances
-      REAL d_t(klon,klev)
-      REAL d_q(klon,klev)
-!
-!   Profiles cible
-      REAL t_targ(klon,klev)
-      REAL rh_targ(klon,klev)
-!
-!   Temps de relaxation
-      REAL tau
-!c      DATA tau /3600./
-!!      DATA tau /5400./
-      DATA tau /1800./
-!
-   INTEGER k,i
-   REAL zx_qs, rh, tnew, d_rh
-
-! Declaration des constantes et des fonctions thermodynamiques
-!
-include "YOMCST.h"
-include "YOETHF.h"
-!
-!  ----------------------------------------
-!  Statement functions
-include "FCTTRE.h"
-!  ----------------------------------------
-!
-        print *,'dtime, tau ',dtime,tau
-        print *, 't_targ',t_targ
-        print *, 'rh_targ',rh_targ
-        print *,'temp ',t
-        print *,'hum ',q
-        DO k = 1,klev
-         DO i = 1,klon
-!!           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
-            IF (t(i,k).LT.RTT) THEN
-               zx_qs = qsats(t(i,k))/(pplay(i,k))
-            ELSE
-               zx_qs = qsatl(t(i,k))/(pplay(i,k))
-            ENDIF
-            rh = q(i,k)/zx_qs
-!
-            d_t(i,k) = d_t(i,k) + 1./tau*(t_targ(i,k)-t(i,k))
-            d_rh = 1./tau*(rh_targ(i,k)-rh)
-!
-            tnew = t(i,k)+d_t(i,k)
-            IF (tnew.LT.RTT) THEN
-               zx_qs = qsats(tnew)/(pplay(i,k))
-            ELSE
-               zx_qs = qsatl(tnew)/(pplay(i,k))
-            ENDIF
-            d_q(i,k) = d_q(i,k) + d_rh*zx_qs
-!
-            print *,' k,d_t,rh,d_rh,d_q ',    &
-                      k,d_t(i,k),rh,d_rh,d_q(i,k)
-!!           ENDIF
-!
-         ENDDO
-        ENDDO
-!
-      RETURN
-      END
-
-      Subroutine Nudge_UV (dtime,paprs,pplay,u_targ,v_targ,u,v,          &
-     &                      d_u,d_v)
-! ========================================================
-  USE dimphy
-
-  implicit none
-
-! ========================================================
-      REAL dtime
-      REAL paprs(klon,klevp1)
-      REAL pplay(klon,klev)
-!
-!      Variables d'etat
-      REAL u(klon,klev)
-      REAL v(klon,klev)
-!
-! Tendances
-      REAL d_u(klon,klev)
-      REAL d_v(klon,klev)
-!
-!   Profiles cible
-      REAL u_targ(klon,klev)
-      REAL v_targ(klon,klev)
-!
-!   Temps de relaxation
-      REAL tau
-!c      DATA tau /3600./
-      DATA tau /5400./
-!
-   INTEGER k,i
-
-!
-        print *,'dtime, tau ',dtime,tau
-        print *, 'u_targ',u_targ
-        print *, 'v_targ',v_targ
-        print *,'zonal velocity ',u
-        print *,'meridional velocity ',v
-        DO k = 1,klev
-         DO i = 1,klon
-           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
-!
-            d_u(i,k) = d_u(i,k) + 1./tau*(u_targ(i,k)-u(i,k))
-            d_v(i,k) = d_v(i,k) + 1./tau*(v_targ(i,k)-v(i,k))
-!
-            print *,' k,u,d_u,v,d_v ',    &
-                      k,u(i,k),d_u(i,k),v(i,k),d_v(i,k)
-           ENDIF
-!
-         ENDDO
-        ENDDO
-!
-      RETURN
-      END
-
Index: LMDZ5/branches/testing/libf/phylmd/1D_decl_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1D_decl_cases.h	(revision 2274)
+++ 	(revision )
@@ -1,254 +1,0 @@
-#include "netcdf.inc"
-
-! Declarations specifiques au cas Toga
-        character*80 :: fich_toga
-!        integer nlev_prof
-!        parameter (nlev_prof = 41)
-        integer nlev_toga, nt_toga
-        parameter (nlev_toga=41, nt_toga=480)
-        integer year_ini_toga, day_ini_toga, mth_ini_toga
-        real day_ju_ini_toga   ! Julian day of toga coare first day
-        parameter (year_ini_toga=1992) 
-        parameter (mth_ini_toga=11)
-        parameter (day_ini_toga=1)  !  1erNov1992
-        real dt_toga
-        parameter (dt_toga=6.*3600.)
-!!
-        integer year_print, month_print, day_print
-        real    sec_print
-!!
-        real ts_toga(nt_toga)
-        real plev_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)
-        real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)
-        real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)
-        real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
-        real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
-
-        real ts_prof
-        real plev_prof(nlev_toga),w_prof(nlev_toga)
-        real t_prof(nlev_toga),q_prof(nlev_toga)
-        real u_prof(nlev_toga),v_prof(nlev_toga)
-        real ht_prof(nlev_toga),vt_prof(nlev_toga)
-        real hq_prof(nlev_toga),vq_prof(nlev_toga)
-
-        real w_mod(llm), t_mod(llm),q_mod(llm)
-        real u_mod(llm),v_mod(llm), ht_mod(llm),vt_mod(llm)
-        real hq_mod(llm),vq_mod(llm),qv_mod(llm),ql_mod(llm),qt_mod(llm)
-        real th_mod(llm)
-
-        real ts_cur
-        common /sst_forcing/ts_cur ! also in read_tsurf1d.F
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Declarations specifiques au cas RICO
-        character*80 :: fich_rico
-        integer nlev_rico
-
-        parameter (nlev_rico=81)
-        real ts_rico,ps_rico
-        real w_rico(llm)
-        real t_rico(llm),q_rico(llm)
-        real u_rico(llm),v_rico(llm)
-        real dth_rico(llm)
-        real dqh_rico(llm)
-        real du_age(llm),dv_age(llm)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Declarations specifiques au cas TWPice
-        character*80 :: fich_twpice
-        integer nlev_twpi, nt_twpi
-        parameter (nlev_twpi=40, nt_twpi=215)
-        integer year_ini_twpi, day_ini_twpi, mth_ini_twpi
-        real heure_ini_twpi
-        real day_ju_ini_twpi   ! Julian day of twpice first day
-        parameter (year_ini_twpi=2006) 
-        parameter (mth_ini_twpi=1)
-        parameter (day_ini_twpi=17)  ! 17 = 17Jan2006
-        parameter (heure_ini_twpi=10800.) !3h en secondes
-        real dt_twpi
-        parameter (dt_twpi=3.*3600.)
-
-        real ts_twpi(nt_twpi)
-        real plev_twpi(nlev_twpi,nt_twpi),w_twpi(nlev_twpi,nt_twpi)
-        real t_twpi(nlev_twpi,nt_twpi),q_twpi(nlev_twpi,nt_twpi)
-        real u_twpi(nlev_twpi,nt_twpi),v_twpi(nlev_twpi,nt_twpi)
-        real ht_twpi(nlev_twpi,nt_twpi),vt_twpi(nlev_twpi,nt_twpi)
-        real hq_twpi(nlev_twpi,nt_twpi),vq_twpi(nlev_twpi,nt_twpi)
-
-        real ts_proftwp
-        real plev_proftwp(nlev_twpi),w_proftwp(nlev_twpi)
-        real t_proftwp(nlev_twpi),q_proftwp(nlev_twpi)
-        real u_proftwp(nlev_twpi),v_proftwp(nlev_twpi)
-        real ht_proftwp(nlev_twpi),vt_proftwp(nlev_twpi)
-        real hq_proftwp(nlev_twpi),vq_proftwp(nlev_twpi)
-
-
-
-!Declarations specifiques au cas FIRE
-        character*80 :: fich_fire
-        integer nlev_fire, nt_fire
-        parameter (nlev_fire=120, nt_fire=1)  
-        integer year_ini_fire, day_ini_fire, mth_ini_fire
-        real heure_ini_fire
-        parameter (year_ini_fire=1987) 
-        parameter (mth_ini_fire=7)
-        parameter (day_ini_fire=14)  ! 14 = 14Juil1987
-        parameter (heure_ini_fire=0.) !0h en secondes
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!Declarations specifiques au cas DICE     (MPL 02072013)
-        character*80 :: fich_dice
-        integer nlev_dice, nt_dice
-        parameter (nlev_dice=70, nt_dice=145)  
-        integer year_ini_dice, day_ini_dice, mth_ini_dice
-        real heure_ini_dice
-        real day_ju_ini_dice   ! Julian day of dice first day
-        parameter (year_ini_dice=1999) 
-        parameter (mth_ini_dice=10)
-        parameter (day_ini_dice=23)  ! 23 = 23 october 1999
-        parameter (heure_ini_dice=68400.) !19UTC en secondes
-        real dt_dice
-        parameter (dt_dice=0.5*3600.) ! 1 forcage ttes les demi-heures
-
-!profils initiaux:
-        real plev_dice(nlev_dice)
-        
-        real zz_dice(nlev_dice)
-        real th_dice(nlev_dice),qv_dice(nlev_dice)
-        real u_dice(nlev_dice), v_dice(nlev_dice),o3_dice(nlev_dice)
-        real ht_dice(nlev_dice,nt_dice)
-        real hq_dice(nlev_dice,nt_dice), hu_dice(nlev_dice,nt_dice)
-        real hv_dice(nlev_dice,nt_dice)
-        real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)
-        real o3_mod(llm),hu_mod(llm),hv_mod(llm)
-        real th_dicei(nlev_dice),qv_dicei(nlev_dice)
-        real u_dicei(nlev_dice), v_dicei(nlev_dice),o3_dicei(nlev_dice)
-        real ht_dicei(nlev_dice)
-        real hq_dicei(nlev_dice), hu_dicei(nlev_dice)
-        real hv_dicei(nlev_dice)
-        real w_dicei(nlev_dice),omega_dicei(nlev_dice)
-
-        
-!forcings
-        real shf_dice(nt_dice),lhf_dice(nt_dice)
-        real lwup_dice(nt_dice),swup_dice(nt_dice)
-        real tg_dice(nt_dice),ustar_dice(nt_dice),psurf_dice(nt_dice)
-        real ug_dice(nt_dice),vg_dice(nt_dice)
-
-        real shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof
-        real ustar_prof,psurf_prof,cdrag
-        real ht_profd(nlev_dice),hq_profd(nlev_dice),hu_profd(nlev_dice)
-        real hv_profd(nlev_dice),w_profd(nlev_dice)
-        real omega_profd(nlev_dice),ug_profd,vg_profd
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Declarations specifiques au cas GCSSold
-        character*80 :: fich_gcssold_ctl
-        character*80 :: fich_gcssold_dat
-        real  ht_gcssold(llm),hq_gcssold(llm),hw_gcssold(llm)
-        real  hu_gcssold(llm)
-        real  hv_gcssold(llm)
-        real  hthturb_gcssold(llm)
-        real  hqturb_gcssold(llm)
-        real  Ts_gcssold
-        real  dtime_frcg
-        logical :: Turb_fcg_gcssold
-
-        common /turb_forcing/                                                   &
-     &  dtime_frcg,hthturb_gcssold, hqturb_gcssold,Turb_fcg_gcssold
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Declarations specifiques au cas Arm_cu
-        character*80 :: fich_armcu
-
-
-        integer nlev_armcu, nt_armcu
-        parameter (nlev_armcu=40, nt_armcu=31)
-        integer year_ini_armcu, day_ini_armcu, mth_ini_armcu
-        real  heure_ini_armcu
-        real day_ju_ini_armcu                                ! Julian day of armcu case first day
-        parameter (year_ini_armcu=1997) 
-        parameter (mth_ini_armcu=6)
-        parameter (day_ini_armcu=21)  ! 172 = 21 juin 1997
-        parameter (heure_ini_armcu=41400)   ! 11:30 en secondes
-        real dt_armcu
-        parameter (dt_armcu=1.*1800.)   ! forcages donnes ttes les demi-heures par ifa_armcu.txt
-        real sens_armcu(nt_armcu),flat_armcu(nt_armcu)
-        real adv_theta_armcu(nt_armcu),rad_theta_armcu(nt_armcu)
-        real adv_qt_armcu(nt_armcu)
-        real theta_mod(llm),rv_mod(llm),play_mod(llm)
-! profc comme "profil armcu"
-        
-! forcages interpoles dans le temps
-        real adv_theta_prof,rad_theta_prof,adv_qt_prof
-        real sens_prof,flat_prof,fact
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! declarations specifiques au cas Sandu
-        character*80 :: fich_sandu
-!        integer nlev_prof
-!        parameter (nlev_prof = 41)
-        integer nlev_sandu, nt_sandu
-        parameter (nlev_sandu=87, nt_sandu=13)
-        integer year_ini_sandu, day_ini_sandu, mth_ini_sandu
-        real day_ju_ini_sandu                                ! Julian day of sandu case first day
-        parameter (year_ini_sandu=2006)
-        parameter (mth_ini_sandu=7)
-        parameter (day_ini_sandu=15)  ! 196 = 15 juillet 2006
-        real dt_sandu, tau_sandu
-        logical  :: trouve_700=.true.
-        parameter (dt_sandu=6.*3600.)   ! forcages donnes ttes les 6 heures par ifa_sandu.txt
-        parameter (tau_sandu=3600.)  ! temps de relaxation u,v,thetal,qt vers profil init et au dessus 700hPa
-!!
-        real ts_sandu(nt_sandu)
-! profs comme "profil sandu"
-        real plev_profs(nlev_sandu)
-        real t_profs(nlev_sandu),thl_profs(nlev_sandu)
-        real q_profs(nlev_sandu)
-        real u_profs(nlev_sandu),v_profs(nlev_sandu),w_profs(nlev_sandu)
-        real omega_profs(nlev_sandu),o3mmr_profs(nlev_sandu)
-
-        real, dimension(llm) :: relax_u,relax_v,relax_thl
-        real, dimension(llm,2) :: relax_q
-
-        real thl_mod(llm),omega_mod(llm),o3mmr_mod(llm),tke_mod(llm)
-!vertical advection computation
-        real d_t_z(llm), d_q_z(llm)
-        real d_t_dyn_z(llm), d_q_dyn_z(llm)
-        real d_u_z(llm),d_v_z(llm)
-        real d_u_dyn(llm),d_v_dyn(llm)
-        real d_u_dyn_z(llm),d_v_dyn_z(llm)
-        real d_u_adv(llm),d_v_adv(llm)
-        real zz(llm)
-        real zfact
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Declarations specifiques au cas Astex
-        character*80 :: fich_astex
-        integer nlev_astex, nt_astex
-        parameter (nlev_astex=34, nt_astex=49)
-        integer year_ini_astex, day_ini_astex, mth_ini_astex
-        real day_ju_ini_astex                                ! Julian day of astex case first day
-        parameter (year_ini_astex=1992)
-        parameter (mth_ini_astex=6)
-        parameter (day_ini_astex=13)  ! 165 = 13 juin 1992
-        real dt_astex
-        parameter (dt_astex=3600.)    ! forcages donnes ttes les heures par ifa_astex.txt
-        real ts_astex(nt_astex),div_astex(nt_astex),ug_astex(nt_astex)
-        real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
-        real div_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
-! profa comme "profil astex"
-        real plev_profa(nlev_astex)
-        real t_profa(nlev_astex),thl_profa(nlev_astex)
-        real qv_profa(nlev_astex),ql_profa(nlev_astex)
-        real qt_profa(nlev_astex),o3mmr_profa(nlev_astex)
-        real u_profa(nlev_astex),v_profa(nlev_astex),w_profa(nlev_astex)
-        real tke_profa(nlev_astex)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!Declarations specifiques au cas standard
-
-        real w_mod_cas(llm), t_mod_cas(llm),q_mod_cas(llm)
-        real ug_mod_cas(llm),vg_mod_cas(llm)
-        real u_mod_cas(llm),v_mod_cas(llm)
-        real ht_mod_cas(llm),vt_mod_cas(llm),dt_mod_cas(llm),dtrad_mod_cas(llm)
-        real hq_mod_cas(llm),vq_mod_cas(llm),dq_mod_cas(llm)
-        real hu_mod_cas(llm),vu_mod_cas(llm),du_mod_cas(llm)
-        real hv_mod_cas(llm),vv_mod_cas(llm),dv_mod_cas(llm)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
Index: LMDZ5/branches/testing/libf/phylmd/1D_interp_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1D_interp_cases.h	(revision 2274)
+++ 	(revision )
@@ -1,757 +1,0 @@
-!---------------------------------------------------------------------
-! Interpolation forcing in time and onto model levels
-!---------------------------------------------------------------------
-      if (forcing_GCSSold) then
-
-       call get_uvd(it,timestep,fich_gcssold_ctl,fich_gcssold_dat,              &
-     &               ht_gcssold,hq_gcssold,hw_gcssold,                          &
-     &               hu_gcssold,hv_gcssold,                                     &
-     &               hthturb_gcssold,hqturb_gcssold,Ts_gcssold,                 &
-     &               imp_fcg_gcssold,ts_fcg_gcssold,                            &
-     &               Tp_fcg_gcssold,Turb_fcg_gcssold)
-       if (prt_level.ge.1) then
-         print *,' get_uvd -> hqturb_gcssold ',it,hqturb_gcssold
-       endif
-! large-scale forcing :
-!!!      tsurf = ts_gcssold
-      do l = 1, llm
-!       u(l) = hu_gcssold(l) !  on prescrit le vent
-!       v(l) = hv_gcssold(l)    !  on prescrit le vent
-!       omega(l) = hw_gcssold(l)
-!       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!       omega2(l)=-rho(l)*omega(l)
-       omega(l) = hw_gcssold(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-       d_th_adv(l) = ht_gcssold(l)
-       d_q_adv(l,1) = hq_gcssold(l)
-       dt_cooling(l) = 0.0
-      enddo
-
-      endif ! forcing_GCSSold
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation Toga forcing 
-!---------------------------------------------------------------------
-      if (forcing_toga) then
-
-       if (prt_level.ge.1) then
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_toga=',     &
-     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_toga
-       endif
-
-! time interpolation:
-        CALL interp_toga_time(daytime,day1,annee_ref                        &
-     &             ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga           &
-     &             ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga        &
-     &             ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga           &
-     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof    &
-     &             ,ht_prof,vt_prof,hq_prof,vq_prof)
-
-        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
-
-! vertical interpolation:
-      CALL interp_toga_vertical(play,nlev_toga,plev_prof                    &
-     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                          &
-     &         ,ht_prof,vt_prof,hq_prof,vq_prof                             &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-
-! large-scale forcing :
-      tsurf = ts_prof
-      do l = 1, llm
-       u(l) = u_mod(l) ! sb: on prescrit le vent
-       v(l) = v_mod(l) ! sb: on prescrit le vent
-!       omega(l) = w_prof(l)
-!       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!       omega2(l)=-rho(l)*omega(l)
-       omega(l) = w_mod(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-       d_th_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l))
-       d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l))
-       dt_cooling(l) = 0.0
-      enddo
-
-      endif ! forcing_toga
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Interpolation DICE forcing 
-!---------------------------------------------------------------------
-      if (forcing_dice) then
-
-       if (prt_level.ge.1) then
-        print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_dice=',&
-     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_dice
-       endif
-
-! time interpolation:
-      CALL interp_dice_time(daytime,day1,annee_ref                    &
-     &             ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice     & 
-     &             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice   &
-     &             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice     &
-     &             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice &
-     &             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof     &
-     &             ,ustar_prof,psurf_prof,ug_profd,vg_profd           &
-     &             ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd       &
-     &             ,omega_profd)
-!     do l = 1, llm
-!     print *,'llm l omega_profd',llm,l,omega_profd(l)
-!     enddo
-
-        if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d
-
-! vertical interpolation:
-      CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice        &
-     &         ,th_dice,qv_dice,u_dice,v_dice,o3_dice                   &
-     &         ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd,omega_profd &
-     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                        &
-     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
-!     do l = 1, llm
-!      print *,'llm l omega_mod',llm,l,omega_mod(l)
-!     enddo
-
-! Les forcages DICE sont donnes /jour et non /seconde !
-      ht_mod(:)=ht_mod(:)/86400.
-      hq_mod(:)=hq_mod(:)/86400.
-      hu_mod(:)=hu_mod(:)/86400.
-      hv_mod(:)=hv_mod(:)/86400.
-
-!calcul de l'advection verticale a partir du omega (repris cas TWPICE, MPL 05082013)
-!Calcul des gradients verticaux
-!initialisation
-      d_t_z(:)=0.
-      d_q_z(:)=0.
-      d_u_z(:)=0.
-      d_v_z(:)=0.
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
-       d_q_z(l)=(q(l+1,1)-q(l-1,1)) /(play(l+1)-play(l-1))
-       d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1))
-       d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1))
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-!     d_u_z(1)=u(2)/(play(2)-psurf)/5.
-!     d_v_z(1)=v(2)/(play(2)-psurf)/5.
-      d_u_z(1)=0.
-      d_v_z(1)=0.
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-      d_u_z(llm)=d_u_z(llm-1)
-      d_v_z(llm)=d_v_z(llm-1)
-
-!Calcul de l advection verticale: 
-! utiliser omega (Pa/s) et non w (m/s) !! MP 20131108
-      d_t_dyn_z(:)=omega_mod(:)*d_t_z(:)
-      d_q_dyn_z(:)=omega_mod(:)*d_q_z(:)
-      d_u_dyn_z(:)=omega_mod(:)*d_u_z(:)
-      d_v_dyn_z(:)=omega_mod(:)*d_v_z(:)
-
-! large-scale forcing :
-!     tsurf = tg_prof    MPL 20130925 commente
-      psurf = psurf_prof
-! For this case, fluxes are imposed
-      fsens=-1*shf_prof
-      flat=-1*lhf_prof
-      ust=ustar_prof
-      tg=tg_prof
-      print *,'ust= ',ust
-      do l = 1, llm
-       ug(l)= ug_profd
-       vg(l)= vg_profd
-!       omega(l) = w_prof(l)
-!      rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!       omega2(l)=-rho(l)*omega(l)
-!      omega(l) = w_mod(l)*(-rg*rho(l))
-       omega(l) = omega_mod(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l)
-       d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l)
-       d_u_adv(l) = hu_mod(l)-d_u_dyn_z(l)
-       d_v_adv(l) = hv_mod(l)-d_v_dyn_z(l)
-       dt_cooling(l) = 0.0
-      enddo
-
-      endif ! forcing_dice
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing TWPice
-!---------------------------------------------------------------------
-      if (forcing_twpice) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_twpi=',     &
-     &    daytime,day1,(daytime-day1)*86400.,                               &
-     &    (daytime-day1)*86400/dt_twpi
-
-! time interpolation:
-        CALL interp_toga_time(daytime,day1,annee_ref                        &
-     &       ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi       &
-     &       ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi          &
-     &       ,ht_twpi,vt_twpi,hq_twpi,vq_twpi                               &
-     &       ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp,u_proftwp         &
-     &       ,v_proftwp,w_proftwp                                           &
-     &       ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp)
-
-! vertical interpolation:
-      CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp                 &
-     &         ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp           &
-     &         ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp                 &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-
-
-!calcul de l'advection verticale a partir du omega
-!Calcul des gradients verticaux
-!initialisation
-      d_t_z(:)=0.
-      d_q_z(:)=0.
-      d_t_dyn_z(:)=0.
-      d_q_dyn_z(:)=0.
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
-       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-
-!Calcul de l advection verticale
-      d_t_dyn_z(:)=w_mod(:)*d_t_z(:)
-      d_q_dyn_z(:)=w_mod(:)*d_q_z(:)
-
-!wind nudging above 500m with a 2h time scale
-        do l=1,llm
-        if (nudge_wind) then
-!           if (phi(l).gt.5000.) then
-        if (phi(l).gt.0.) then
-        u(l)=u(l)+timestep*(u_mod(l)-u(l))/(2.*3600.)
-        v(l)=v(l)+timestep*(v_mod(l)-v(l))/(2.*3600.)
-           endif    
-        else
-        u(l) = u_mod(l) 
-        v(l) = v_mod(l)
-        endif
-        enddo
-
-!CR:nudging of q and theta with a 6h time scale above 15km
-        if (nudge_thermo) then
-        do l=1,llm
-           zz(l)=phi(l)/9.8
-           if ((zz(l).le.16000.).and.(zz(l).gt.15000.)) then
-             zfact=(zz(l)-15000.)/1000.
-        q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)*zfact
-        temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)*zfact
-           else if (zz(l).gt.16000.) then 
-        q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)
-        temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)
-           endif
-        enddo    
-        endif
-
-      do l = 1, llm
-       omega(l) = w_mod(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!calcul de l'advection totale
-        if (cptadvw) then
-        d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l)
-!        print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l)
-        d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l)
-!        print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l)
-        else
-        d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l))
-        d_q_adv(l,1) = (hq_mod(l)+vq_mod(l))
-        endif
-       dt_cooling(l) = 0.0
-      enddo
-
-      endif ! forcing_twpice
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing AMMA
-!---------------------------------------------------------------------
-
-       if (forcing_amma) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_amma=',     &
-     &    daytime,day1,(daytime-day1)*86400.,                               &
-     &    (daytime-day1)*86400/dt_amma
-
-! time interpolation using TOGA interpolation routine
-        CALL interp_amma_time(daytime,day1,annee_ref                        &
-     &       ,year_ini_amma,day_ju_ini_amma,nt_amma,dt_amma,nlev_amma       &
-     &       ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma                  &
-     &       ,vitw_profamma,ht_profamma,hq_profamma,lat_profamma            &
-     &       ,sens_profamma)
-
-      print*,'apres interpolation temporelle AMMA'
-
-      do k=1,nlev_amma
-         th_profamma(k)=0.
-         q_profamma(k)=0.
-         u_profamma(k)=0.
-         v_profamma(k)=0.
-         vt_profamma(k)=0.
-         vq_profamma(k)=0.
-       enddo
-! vertical interpolation using TOGA interpolation routine:
-!      write(*,*)'avant interp vert', t_proftwp
-      CALL interp_toga_vertical(play,nlev_amma,plev_amma                      &
-     &         ,th_profamma,q_profamma,u_profamma,v_profamma                 &
-     &         ,vitw_profamma                                               &
-     &         ,ht_profamma,vt_profamma,hq_profamma,vq_profamma             &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-       write(*,*) 'Profil initial forcing AMMA interpole'
-
-
-!calcul de l'advection verticale a partir du omega
-!Calcul des gradients verticaux
-!initialisation
-      do l=1,llm
-      d_t_z(l)=0.
-      d_q_z(l)=0.
-      enddo
-
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
-       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-
-
-      do l = 1, llm
-       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-       omega(l) = w_mod(l)*(-rg*rho(l))
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!calcul de l'advection totale
-!        d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-omega(l)*d_t_z(l)
-!attention: on impose dth
-        d_th_adv(l) = alpha*omega(l)/rcpd+                                  &
-     &         ht_mod(l)*(play(l)/pzero)**rkappa-omega(l)*d_t_z(l)
-!        d_th_adv(l) = 0.
-!        print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l)
-        d_q_adv(l,1) = hq_mod(l)-omega(l)*d_q_z(l)
-!        d_q_adv(l,1) = 0.
-!        print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l)
-   
-       dt_cooling(l) = 0.0
-      enddo
-
-
-!     ok_flux_surf=.false.
-      fsens=-1.*sens_profamma
-      flat=-1.*lat_profamma
-
-      endif ! forcing_amma
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing Rico
-!---------------------------------------------------------------------
-      if (forcing_rico) then
-!       call lstendH(llm,omega,dt_dyn,dq_dyn,du_dyn, dv_dyn,
-!     :  q,temp,u,v,play)
-       call lstendH(llm,nqtot,omega,dt_dyn,dq_dyn,q,temp,u,v,play)
-
-        do l=1,llm
-       d_th_adv(l) =  (dth_rico(l) +  dt_dyn(l))
-       d_q_adv(l,1) = (dqh_rico(l) +  dq_dyn(l,1))
-       d_q_adv(l,2) = 0.
-        enddo
-      endif  ! forcing_rico
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing Arm_cu
-!---------------------------------------------------------------------
-      if (forcing_armcu) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_armcu=',    &
-     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_armcu
-
-! time interpolation:
-! ATTENTION, cet appel ne convient pas pour TOGA !!
-! revoir 1DUTILS.h et les arguments
-      CALL interp_armcu_time(daytime,day1,annee_ref                         &
-     &            ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu        &
-     &            ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu          &
-     &            ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof         &
-     &            ,adv_theta_prof,rad_theta_prof,adv_qt_prof)
-
-! vertical interpolation:
-! No vertical interpolation if nlev imposed to 19 or 40
-
-! For this case, fluxes are imposed
-       fsens=-1*sens_prof
-       flat=-1*flat_prof
-
-! Advective forcings are given in K or g/kg ... BY HOUR
-      do l = 1, llm
-       ug(l)= u_mod(l)
-       vg(l)= v_mod(l)
-       IF((phi(l)/RG).LT.1000) THEN
-         d_th_adv(l) = (adv_theta_prof + rad_theta_prof)/3600.
-         d_q_adv(l,1) = adv_qt_prof/1000./3600.
-         d_q_adv(l,2) = 0.0
-!        print *,'INF1000: phi dth dq1 dq2',
-!    :  phi(l)/RG,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
-       ELSEIF ((phi(l)/RG).GE.1000.AND.(phi(l)/RG).lt.3000) THEN
-         fact=((phi(l)/RG)-1000.)/2000.
-         fact=1-fact
-         d_th_adv(l) = (adv_theta_prof + rad_theta_prof)*fact/3600.
-         d_q_adv(l,1) = adv_qt_prof*fact/1000./3600.
-         d_q_adv(l,2) = 0.0
-!        print *,'SUP1000: phi fact dth dq1 dq2',
-!    :  phi(l)/RG,fact,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
-       ELSE
-         d_th_adv(l) = 0.0
-         d_q_adv(l,1) = 0.0
-         d_q_adv(l,2) = 0.0
-!        print *,'SUP3000: phi dth dq1 dq2',
-!    :  phi(l)/RG,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
-       ENDIF
-      dt_cooling(l) = 0.0  
-!     print *,'Interp armcu: phi dth dq1 dq2',
-!    :  l,phi(l),d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
-      enddo
-      endif ! forcing_armcu
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing in time and onto model levels
-!---------------------------------------------------------------------
-      if (forcing_sandu) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_sandu=',    &
-     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_sandu 
-
-! time interpolation:
-! ATTENTION, cet appel ne convient pas pour TOGA !!
-! revoir 1DUTILS.h et les arguments
-      CALL interp_sandu_time(daytime,day1,annee_ref                         &
-     &             ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu       &
-     &             ,nlev_sandu                                              &
-     &             ,ts_sandu,ts_prof)
-
-        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
-
-! vertical interpolation:
-      CALL interp_sandu_vertical(play,nlev_sandu,plev_profs                 &
-     &         ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs           &
-     &         ,omega_profs,o3mmr_profs                                     &
-     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                       &
-     &         ,omega_mod,o3mmr_mod,mxcalc)
-!calcul de l'advection verticale
-!Calcul des gradients verticaux
-!initialisation
-      d_t_z(:)=0.
-      d_q_z(:)=0.
-      d_t_dyn_z(:)=0.
-      d_q_dyn_z(:)=0.
-! schema centre
-!     DO l=2,llm-1
-!      d_t_z(l)=(temp(l+1)-temp(l-1))
-!    &          /(play(l+1)-play(l-1))
-!      d_q_z(l)=(q(l+1,1)-q(l-1,1))
-!    &          /(play(l+1)-play(l-1))
-! schema amont
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l))
-       d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l))
-!     print *,'l temp2 temp0 play2 play0 omega_mod',
-!    & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l)
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-
-!  calcul de l advection verticale
-! Confusion w (m/s) et omega (Pa/s) !!
-      d_t_dyn_z(:)=omega_mod(:)*d_t_z(:)
-      d_q_dyn_z(:)=omega_mod(:)*d_q_z(:)
-!     do l=1,llm
-!      print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z',
-!    :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l)
-!     enddo
-
-
-! large-scale forcing : pour le cas Sandu ces forcages sont la SST
-! et une divergence constante -> profil de omega
-      tsurf = ts_prof
-      write(*,*) 'SST suivante: ',tsurf
-      do l = 1, llm
-       omega(l) = omega_mod(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!
-!      d_th_adv(l) = 0.0
-!      d_q_adv(l,1) = 0.0
-!CR:test advection=0
-!calcul de l'advection verticale
-        d_th_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l)
-!        print*,'temp adv',l,-d_t_dyn_z(l)
-        d_q_adv(l,1) = -d_q_dyn_z(l)
-!        print*,'q adv',l,-d_q_dyn_z(l)
-       dt_cooling(l) = 0.0
-      enddo
-      endif ! forcing_sandu
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing in time and onto model levels
-!---------------------------------------------------------------------
-      if (forcing_astex) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_astex=',    &
-     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_astex
-
-! time interpolation:
-! ATTENTION, cet appel ne convient pas pour TOGA !!
-! revoir 1DUTILS.h et les arguments
-      CALL interp_astex_time(daytime,day1,annee_ref                         &
-     &             ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex       &
-     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex         &
-     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof    &
-     &             ,ufa_prof,vfa_prof)
-
-        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
-
-! vertical interpolation:
-      CALL interp_astex_vertical(play,nlev_astex,plev_profa                 &
-     &         ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa                &
-     &         ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa               &
-     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod        &
-     &         ,tke_mod,o3mmr_mod,mxcalc)
-!calcul de l'advection verticale
-!Calcul des gradients verticaux
-!initialisation
-      d_t_z(:)=0.
-      d_q_z(:)=0.
-      d_t_dyn_z(:)=0.
-      d_q_dyn_z(:)=0.
-! schema centre
-!     DO l=2,llm-1
-!      d_t_z(l)=(temp(l+1)-temp(l-1))
-!    &          /(play(l+1)-play(l-1))
-!      d_q_z(l)=(q(l+1,1)-q(l-1,1))
-!    &          /(play(l+1)-play(l-1))
-! schema amont
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l))
-       d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l))
-!     print *,'l temp2 temp0 play2 play0 omega_mod',
-!    & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l)
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-
-!  calcul de l advection verticale
-! Confusion w (m/s) et omega (Pa/s) !!
-      d_t_dyn_z(:)=w_mod(:)*d_t_z(:)
-      d_q_dyn_z(:)=w_mod(:)*d_q_z(:)
-!     do l=1,llm
-!      print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z',
-!    :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l)
-!     enddo
-
-
-! large-scale forcing : pour le cas Astex ces forcages sont la SST
-! la divergence,ug,vg,ufa,vfa
-      tsurf = ts_prof
-      write(*,*) 'SST suivante: ',tsurf
-      do l = 1, llm
-       omega(l) = w_mod(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!
-!      d_th_adv(l) = 0.0
-!      d_q_adv(l,1) = 0.0
-!CR:test advection=0
-!calcul de l'advection verticale
-        d_th_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l)
-!        print*,'temp adv',l,-d_t_dyn_z(l)
-        d_q_adv(l,1) = -d_q_dyn_z(l)
-!        print*,'q adv',l,-d_q_dyn_z(l)
-       dt_cooling(l) = 0.0
-      enddo
-      endif ! forcing_astex
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Interpolation forcing standard case
-!---------------------------------------------------------------------
-      if (forcing_case) then
-
-        print*,                                                             &
-     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=',     &
-     &    daytime,day1,(daytime-day1)*86400.,                               &
-     &    (daytime-day1)*86400/pdt_cas
-
-! time interpolation:
-        CALL interp_case_time(daytime,day1,annee_ref                        &
-     &       ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_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                 &
-     &       ,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)
-
-             ts_cur = ts_prof_cas 
-             psurf=plev_prof_cas(1)
-
-! vertical interpolation:
-      CALL interp_case_vertical(play,nlev_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           &
-     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
-
-
-!calcul de l'advection verticale a partir du omega
-!Calcul des gradients verticaux
-!initialisation
-      d_t_z(:)=0.
-      d_q_z(:)=0.
-      d_u_z(:)=0.
-      d_v_z(:)=0.
-      d_t_dyn_z(:)=0.
-      d_q_dyn_z(:)=0.
-      d_u_dyn_z(:)=0.
-      d_v_dyn_z(:)=0.
-      DO l=2,llm-1
-       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
-       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
-       d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1))
-       d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1))
-      ENDDO
-      d_t_z(1)=d_t_z(2)
-      d_q_z(1)=d_q_z(2)
-      d_u_z(1)=d_u_z(2)
-      d_v_z(1)=d_v_z(2)
-      d_t_z(llm)=d_t_z(llm-1)
-      d_q_z(llm)=d_q_z(llm-1)
-      d_u_z(llm)=d_u_z(llm-1)
-      d_v_z(llm)=d_v_z(llm-1)
-
-!Calcul de l advection verticale
-      d_t_dyn_z(:)=w_mod_cas(:)*d_t_z(:)
-      d_q_dyn_z(:)=w_mod_cas(:)*d_q_z(:)
-      d_u_dyn_z(:)=w_mod_cas(:)*d_u_z(:)
-      d_v_dyn_z(:)=w_mod_cas(:)*d_v_z(:)
-
-!wind nudging 
-      if (nudge_u.gt.0.) then
-        do l=1,llm
-           u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u)
-        enddo
-      else
-        do l=1,llm
-        u(l) = u_mod_cas(l) 
-        enddo
-      endif
-
-      if (nudge_v.gt.0.) then
-        do l=1,llm
-           v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v)
-        enddo
-      else
-        do l=1,llm
-        v(l) = v_mod_cas(l) 
-        enddo
-      endif
-
-      if (nudge_w.gt.0.) then
-        do l=1,llm
-           w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w)
-        enddo
-      else
-        do l=1,llm
-        w(l) = w_mod_cas(l) 
-        enddo
-      endif
-
-!nudging of q and temp 
-      if (nudge_t.gt.0.) then
-        do l=1,llm
-           temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t)
-        enddo
-      endif
-      if (nudge_q.gt.0.) then
-        do l=1,llm
-           q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q)
-        enddo
-      endif
-
-      do l = 1, llm
-       omega(l) = w_mod_cas(l)
-       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-
-!calcul advection
-        if ((tend_u.eq.1).and.(tend_w.eq.0)) then
-           d_u_adv(l)=du_mod_cas(l)
-        else if ((tend_u.eq.1).and.(tend_w.eq.1)) then
-           d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l)
-        endif
-
-        if ((tend_v.eq.1).and.(tend_w.eq.0)) then
-           d_v_adv(l)=dv_mod_cas(l)
-        else if ((tend_v.eq.1).and.(tend_w.eq.1)) then
-           d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l)
-        endif
-
-        if ((tend_t.eq.1).and.(tend_w.eq.0)) then
-!           d_th_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l)
-           d_th_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l)
-        else if ((tend_t.eq.1).and.(tend_w.eq.1)) then
-!           d_th_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l)
-           d_th_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l)
-        endif
-
-        if ((tend_q.eq.1).and.(tend_w.eq.0)) then
-!           d_q_adv(l,1)=dq_mod_cas(l)
-           d_q_adv(l,1)=-1*dq_mod_cas(l)
-        else if ((tend_q.eq.1).and.(tend_w.eq.1)) then
-!           d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l)
-           d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l)
-        endif
-         
-        if (tend_rayo.eq.1) then
-           dt_cooling(l) = dtrad_mod_cas(l)
-        else
-           dt_cooling(l) = 0.0
-        endif
-      enddo
-
-      endif ! forcing_case
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
Index: LMDZ5/branches/testing/libf/phylmd/1D_nudge_sandu_astex.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1D_nudge_sandu_astex.h	(revision 2274)
+++ 	(revision )
@@ -1,34 +1,0 @@
-      do l = 1, llm
-!
-! au dessus de 700hPa, on relaxe vers profil init
-!      on fait l'hypothese que dans ce cas, il n'y a plus d'eau liq. au dessus 700hpa
-!      donc la relaxation en thetal et qt devient relaxation en tempe et qv
-       relax_u(l)=(u(l)-u_mod(l))/tau_sandu  ! pour u et v on relaxe sur tte la colonne
-       relax_v(l)=(v(l)-v_mod(l))/tau_sandu
-       relax_q(l,1)=0.
-       relax_q(l,2)=0.
-       relax_thl(l)=0.
-!      print *,'nudge: l tau_sandu u u_mod',l,tau_sandu,u(l),u_mod(l)
-!
-       if (l.ge.llm700) then 
-         relax_q(l,1)=(q(l,1)-q_mod(l))/tau_sandu
-         relax_q(l,2)=0.
-         relax_thl(l)=(temp(l)-t_mod(l))/tau_sandu
-       endif
-!     print *,'l dq1 relax dqadv',l,dq(l,1),relax_q(l,1),d_q_adv(l,1)
-!     print *,'l dq2 relax dqadv',l,dq(l,2),relax_q(l,2),d_q_adv(l,2)
-!     print *,'l dt  relax dtadv',l,dt_phys(l),relax_thl(l),d_th_adv(l)
-      enddo
-        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &          
-     &              du_phys(1:mxcalc) - relax_u(1:mxcalc))
-        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                &
-     &               dv_phys(1:mxcalc) - relax_v(1:mxcalc))
-!       q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(
-!    .              dq(1:mxcalc,:) - relax_q(1:mxcalc,:)+
-!    .              d_q_adv(1:mxcalc,:))
-        q(1:mxcalc,1)=q(1:mxcalc,1)+timestep*(                              &
-     &      dq(1:mxcalc,1) - relax_q(1:mxcalc,1)+d_q_adv(1:mxcalc,1))
-        q(1:mxcalc,2)=q(1:mxcalc,2)+timestep*(                              &
-     &      dq(1:mxcalc,2) - relax_q(1:mxcalc,2)+d_q_adv(1:mxcalc,2))
-        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
-     &      dt_phys(1:mxcalc)-relax_thl(1:mxcalc)+d_th_adv(1:mxcalc))
Index: LMDZ5/branches/testing/libf/phylmd/1D_read_forc_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1D_read_forc_cases.h	(revision 2274)
+++ 	(revision )
@@ -1,782 +1,0 @@
-!----------------------------------------------------------------------
-! forcing_les = .T. : Impose a constant cooling 
-! forcing_radconv = .T. : Pure radiative-convective equilibrium:
-!----------------------------------------------------------------------
-
-
-      nq1=0
-      nq2=0
-
-      if (forcing_les .or. forcing_radconv                                      &
-     &    .or. forcing_GCSSold .or. forcing_fire) then
-
-      if (forcing_fire) then
-!----------------------------------------------------------------------
-!read fire forcings from fire.nc
-!----------------------------------------------------------------------
-      fich_fire='fire.nc'
-      call read_fire(fich_fire,nlev_fire,nt_fire                                &
-     &     ,height,tttprof,qtprof,uprof,vprof,e12prof                           &
-     &     ,ugprof,vgprof,wfls,dqtdxls                                          &
-     &     ,dqtdyls,dqtdtls,thlpcar)
-      write(*,*) 'Forcing FIRE lu'
-      kmax=120            ! nombre de niveaux dans les profils et forcages
-      else 
-!----------------------------------------------------------------------
-! Read profiles from files: prof.inp.001 and lscale.inp.001
-! (repris de readlesfiles)
-!----------------------------------------------------------------------
-
-      call readprofiles(nlev_max,kmax,nqtot,height,                             &
-     &           tttprof,qtprof,uprof,vprof,                                    &
-     &           e12prof,ugprof,vgprof,                                         &
-     &           wfls,dqtdxls,dqtdyls,dqtdtls,                                  &
-     &           thlpcar,qprof,nq1,nq2)
-      endif
-
-! compute altitudes of play levels.
-      zlay(1) =zsurf +  rd*tsurf*(psurf-play(1))/(rg*psurf)
-      do l = 2,llm
-        zlay(l) = zlay(l-1)+rd*tsurf*(psurf-play(1))/(rg*psurf)
-      enddo
-
-!----------------------------------------------------------------------
-! Interpolation of the profiles given on the input file to
-! model levels
-!----------------------------------------------------------------------
-      zlay(1) = zsurf +  rd*tsurf*(psurf-play(1))/(rg*psurf)
-      do l=1,llm
-        ! Above the max altutide of the input file
-
-        if (zlay(l)<height(kmax)) mxcalc=l
-
-        frac = (height(kmax)-zlay(l))/(height (kmax)-height(kmax-1))
-        ttt =tttprof(kmax)-frac*(tttprof(kmax)-tttprof(kmax-1))
-       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
-          temp(l) = ttt*(play(l)/pzero)**rkappa
-          teta(l) = ttt
-       else
-          temp(l) = ttt
-          teta(l) = ttt*(pzero/play(l))**rkappa
-       endif
-          print *,' temp,teta ',l,temp(l),teta(l)
-        q(l,1)  = qtprof(kmax)-frac*( qtprof(kmax)- qtprof(kmax-1))
-        u(l)    =  uprof(kmax)-frac*(  uprof(kmax)-  uprof(kmax-1))
-        v(l)    =  vprof(kmax)-frac*(  vprof(kmax)-  vprof(kmax-1))
-        ug(l)   = ugprof(kmax)-frac*( ugprof(kmax)- ugprof(kmax-1))
-        vg(l)   = vgprof(kmax)-frac*( vgprof(kmax)- vgprof(kmax-1))
-        IF (nq2>0) q(l,nq1:nq2)=qprof(kmax,nq1:nq2)                         &
-     &               -frac*(qprof(kmax,nq1:nq2)-qprof(kmax-1,nq1:nq2))
-        omega(l)=   wfls(kmax)-frac*(   wfls(kmax)-   wfls(kmax-1))
-
-        dq_dyn(l,1) = dqtdtls(kmax)-frac*(dqtdtls(kmax)-dqtdtls(kmax-1))
-        dt_cooling(l)=thlpcar(kmax)-frac*(thlpcar(kmax)-thlpcar(kmax-1))
-        do k=2,kmax
-          frac = (height(k)-zlay(l))/(height(k)-height(k-1))
-          if(l==1) print*,'k, height, tttprof',k,height(k),tttprof(k)
-          if(zlay(l)>height(k-1).and.zlay(l)<height(k)) then
-            ttt =tttprof(k)-frac*(tttprof(k)-tttprof(k-1))
-       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
-          temp(l) = ttt*(play(l)/pzero)**rkappa
-          teta(l) = ttt
-       else
-          temp(l) = ttt
-          teta(l) = ttt*(pzero/play(l))**rkappa
-       endif
-          print *,' temp,teta ',l,temp(l),teta(l)
-            q(l,1)  = qtprof(k)-frac*( qtprof(k)- qtprof(k-1))
-            u(l)    =  uprof(k)-frac*(  uprof(k)-  uprof(k-1))
-            v(l)    =  vprof(k)-frac*(  vprof(k)-  vprof(k-1))
-            ug(l)   = ugprof(k)-frac*( ugprof(k)- ugprof(k-1))
-            vg(l)   = vgprof(k)-frac*( vgprof(k)- vgprof(k-1))
-            IF (nq2>0) q(l,nq1:nq2)=qprof(k,nq1:nq2)                        &
-     &                   -frac*(qprof(k,nq1:nq2)-qprof(k-1,nq1:nq2))
-            omega(l)=   wfls(k)-frac*(   wfls(k)-   wfls(k-1))
-            dq_dyn(l,1)=dqtdtls(k)-frac*(dqtdtls(k)-dqtdtls(k-1))
-            dt_cooling(l)=thlpcar(k)-frac*(thlpcar(k)-thlpcar(k-1))
-          elseif(zlay(l)<height(1)) then ! profils uniformes pour z<height(1)
-            ttt =tttprof(1)
-       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
-          temp(l) = ttt*(play(l)/pzero)**rkappa
-          teta(l) = ttt
-       else
-          temp(l) = ttt
-          teta(l) = ttt*(pzero/play(l))**rkappa
-       endif
-            q(l,1)  = qtprof(1)
-            u(l)    =  uprof(1)
-            v(l)    =  vprof(1)
-            ug(l)   = ugprof(1)
-            vg(l)   = vgprof(1)
-            omega(l)=   wfls(1)
-            IF (nq2>0) q(l,nq1:nq2)=qprof(1,nq1:nq2)
-            dq_dyn(l,1)  =dqtdtls(1)
-            dt_cooling(l)=thlpcar(1)
-          endif
-        enddo 
-
-        temp(l)=max(min(temp(l),350.),150.)
-        rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-        if (l .lt. llm) then
-          zlay(l+1) = zlay(l) + (play(l)-play(l+1))/(rg*rho(l))
-        endif
-        omega2(l)=-rho(l)*omega(l)
-        omega(l)= omega(l)*(-rg*rho(l)) !en Pa/s
-        if (l>1) then
-        if(zlay(l-1)>height(kmax)) then
-           omega(l)=0.0
-           omega2(l)=0.0
-        endif   
-        endif
-        if(q(l,1)<0.) q(l,1)=0.0
-        q(l,2)  = 0.0
-      enddo
-
-      endif ! forcing_les .or. forcing_GCSSold .or. forcing_fire
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing for GCSSold:
-!---------------------------------------------------------------------
-      if (forcing_GCSSold) then
-       fich_gcssold_ctl = './forcing.ctl'
-       fich_gcssold_dat = './forcing8.dat'
-       call copie(llm,play,psurf,fich_gcssold_ctl)
-       call get_uvd2(it,timestep,fich_gcssold_ctl,fich_gcssold_dat,         &
-     &               ht_gcssold,hq_gcssold,hw_gcssold,                      &
-     &               hu_gcssold,hv_gcssold,                                 &
-     &               hthturb_gcssold,hqturb_gcssold,Ts_gcssold,             &
-     &               imp_fcg_gcssold,ts_fcg_gcssold,                        &
-     &               Tp_fcg_gcssold,Turb_fcg_gcssold)
-       print *,' get_uvd2 -> hqturb_gcssold ',hqturb_gcssold
-      endif ! forcing_GCSSold
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing for RICO:
-!---------------------------------------------------------------------
-      if (forcing_rico) then
-
-!       call writefield_phy('omega', omega,llm+1)
-      fich_rico = 'rico.txt'
-       call read_rico(fich_rico,nlev_rico,ps_rico,play                      &
-     &             ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico              &
-     &             ,dth_rico,dqh_rico)
-        print*, ' on a lu et prepare RICO'
-
-       mxcalc=llm
-       print *, airefi, ' airefi '
-       do l = 1, llm
-       rho(l)  = play(l)/(rd*t_rico(l)*(1.+(rv/rd-1.)*q_rico(l)))
-       temp(l) = t_rico(l)
-       q(l,1) = q_rico(l)
-       q(l,2) = 0.0
-       u(l) = u_rico(l)
-       v(l) = v_rico(l)
-       ug(l)=u_rico(l)
-       vg(l)=v_rico(l)
-       omega(l) = -w_rico(l)*rg
-       omega2(l) = omega(l)/rg*airefi
-       enddo
-      endif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from TOGA-COARE experiment (Ciesielski et al. 2002) :
-!---------------------------------------------------------------------
-
-      if (forcing_toga) then
-
-! read TOGA-COARE forcing (native vertical grid, nt_toga timesteps):
-      fich_toga = './d_toga/ifa_toga_coare_v21_dime.txt'
-      CALL read_togacoare(fich_toga,nlev_toga,nt_toga                       &
-     &         ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga        &
-     &         ,ht_toga,vt_toga,hq_toga,vq_toga)
-
-       write(*,*) 'Forcing TOGA lu'
-
-! time interpolation for initial conditions:
-      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
-      CALL interp_toga_time(daytime,day1,annee_ref                          &
-     &             ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga           &
-     &             ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga        &
-     &             ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga           &
-     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof    &
-     &             ,ht_prof,vt_prof,hq_prof,vq_prof)
-
-! vertical interpolation:
-      CALL interp_toga_vertical(play,nlev_toga,plev_prof                    &
-     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                          &
-     &         ,ht_prof,vt_prof,hq_prof,vq_prof                             &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-       write(*,*) 'Profil initial forcing TOGA interpole'
-
-! initial and boundary conditions :
-      tsurf = ts_prof
-      write(*,*) 'SST initiale: ',tsurf
-      do l = 1, llm
-       temp(l) = t_mod(l)
-       q(l,1) = q_mod(l)
-       q(l,2) = 0.0
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       omega(l) = w_mod(l)
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-!?       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!?       omega2(l)=-rho(l)*omega(l)
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-       d_th_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l))
-       d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l))
-       d_q_adv(l,2) = 0.0
-      enddo
-
-      endif ! forcing_toga
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from TWPICE experiment (Shaocheng et al. 2010) :
-!---------------------------------------------------------------------
-
-      if (forcing_twpice) then
-!read TWP-ICE forcings
-     fich_twpice='d_twpi/twp180iopsndgvarana_v2.1_C3.c1.20060117.000000.cdf'
-      call read_twpice(fich_twpice,nlev_twpi,nt_twpi                        &
-     &     ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi            &
-     &     ,ht_twpi,vt_twpi,hq_twpi,vq_twpi)
-
-      write(*,*) 'Forcing TWP-ICE lu'
-!Time interpolation for initial conditions using TOGA interpolation routine
-         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
-      CALL interp_toga_time(daytime,day1,annee_ref                          &
-     &          ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi    &
-     &             ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi    &
-     &             ,ht_twpi,vt_twpi,hq_twpi,vq_twpi                         &
-     &             ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp             &
-     &             ,u_proftwp,v_proftwp,w_proftwp                           &
-     &             ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp)
-
-! vertical interpolation using TOGA interpolation routine:
-!      write(*,*)'avant interp vert', t_proftwp
-      CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp                 &
-     &         ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp           &
-     &         ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp                 &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-!       write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod
-
-! initial and boundary conditions :
-!      tsurf = ts_proftwp
-      write(*,*) 'SST initiale: ',tsurf
-      do l = 1, llm
-       temp(l) = t_mod(l)
-       q(l,1) = q_mod(l)
-       q(l,2) = 0.0
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       omega(l) = w_mod(l)
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!on applique le forcage total au premier pas de temps
-!attention: signe different de toga
-       d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l))
-       d_q_adv(l,1) = (hq_mod(l)+vq_mod(l))
-       d_q_adv(l,2) = 0.0
-      enddo     
-       
-      endif !forcing_twpice
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from AMMA experiment (Couvreux et al. 2010) :
-!---------------------------------------------------------------------
-
-      if (forcing_amma) then
-
-      call read_1D_cases
-
-      write(*,*) 'Forcing AMMA lu'
-
-!champs initiaux:
-      do k=1,nlev_amma
-         th_ammai(k)=th_amma(k)
-         q_ammai(k)=q_amma(k)
-         u_ammai(k)=u_amma(k)
-         v_ammai(k)=v_amma(k)
-         vitw_ammai(k)=vitw_amma(k,12)
-         ht_ammai(k)=ht_amma(k,12)
-         hq_ammai(k)=hq_amma(k,12)
-         vt_ammai(k)=0.
-         vq_ammai(k)=0.
-      enddo   
-      omega(:)=0.      
-      omega2(:)=0.
-      rho(:)=0.
-! vertical interpolation using TOGA interpolation routine:
-!      write(*,*)'avant interp vert', t_proftwp
-      CALL interp_toga_vertical(play,nlev_amma,plev_amma                    &
-     &         ,th_ammai,q_ammai,u_ammai,v_ammai,vitw_ammai                 &
-     &         ,ht_ammai,vt_ammai,hq_ammai,vq_ammai                         &
-     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
-     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
-!       write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod
-
-! initial and boundary conditions :
-!      tsurf = ts_proftwp
-      write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc
-      do l = 1, llm
-! Ligne du dessous à decommenter si on lit theta au lieu de temp
-!      temp(l) = t_mod(l)*(play(l)/pzero)**rkappa 
-       temp(l) = t_mod(l) 
-       q(l,1) = q_mod(l)
-       q(l,2) = 0.0
-!      print *,'read_forc: l,temp,q=',l,temp(l),q(l,1)
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-       omega(l) = w_mod(l)*(-rg*rho(l))
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!on applique le forcage total au premier pas de temps
-!attention: signe different de toga
-       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)
-!forcage en th
-!       d_th_adv(l) = ht_mod(l)
-       d_q_adv(l,1) = hq_mod(l)
-       d_q_adv(l,2) = 0.0
-       dt_cooling(l)=0.
-      enddo     
-       write(*,*) 'Prof initeforcing AMMA interpole temp39',temp(39)
-      
-
-!     ok_flux_surf=.false.
-      fsens=-1.*sens_amma(12)
-      flat=-1.*lat_amma(12)
-       
-      endif !forcing_amma
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from DICE experiment (see file DICE_protocol_vn2-3.pdf)
-!---------------------------------------------------------------------
-
-      if (forcing_dice) then
-!read DICE forcings
-      fich_dice='dice_driver.nc'
-      call read_dice(fich_dice,nlev_dice,nt_dice                    &
-     &     ,zz_dice,plev_dice,th_dice,qv_dice,u_dice,v_dice,o3_dice &
-     &     ,shf_dice,lhf_dice,lwup_dice,swup_dice,tg_dice,ustar_dice& 
-     &     ,psurf_dice,ug_dice,vg_dice,ht_dice,hq_dice              &
-     &     ,hu_dice,hv_dice,w_dice,omega_dice)
-
-      write(*,*) 'Forcing DICE lu'
-
-!champs initiaux:
-      do k=1,nlev_dice
-         th_dicei(k)=th_dice(k)
-         qv_dicei(k)=qv_dice(k)
-         u_dicei(k)=u_dice(k)
-         v_dicei(k)=v_dice(k)
-         o3_dicei(k)=o3_dice(k)
-         ht_dicei(k)=ht_dice(k,1)
-         hq_dicei(k)=hq_dice(k,1)
-         hu_dicei(k)=hu_dice(k,1)
-         hv_dicei(k)=hv_dice(k,1)
-         w_dicei(k)=w_dice(k,1)
-         omega_dicei(k)=omega_dice(k,1)
-      enddo   
-      omega(:)=0.      
-      omega2(:)=0.
-      rho(:)=0.
-! vertical interpolation using TOGA interpolation routine:
-!      write(*,*)'avant interp vert', t_proftwp
-!
-!     CALL interp_dice_time(daytime,day1,annee_ref
-!    i             ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice
-!    i             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice
-!    i             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice
-!    i             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice
-!    o             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof
-!    o             ,ustar_prof,psurf_prof,ug_profd,vg_profd
-!    o             ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd
-!    o             ,omega_profd)
-
-      CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice       &
-     &         ,th_dicei,qv_dicei,u_dicei,v_dicei,o3_dicei             &
-     &         ,ht_dicei,hq_dicei,hu_dicei,hv_dicei,w_dicei,omega_dicei&
-     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                       &
-     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
-
-! Pour tester les advections horizontales de T et Q, on met w_mod et omega_mod à zero (MPL 20131108)
-!     w_mod(:,:)=0.
-!     omega_mod(:,:)=0.
-
-!       write(*,*) 'Profil initial forcing DICE interpole',t_mod
-! Les forcages DICE sont donnes /jour et non /seconde !
-      ht_mod(:)=ht_mod(:)/86400.
-      hq_mod(:)=hq_mod(:)/86400.
-      hu_mod(:)=hu_mod(:)/86400.
-      hv_mod(:)=hv_mod(:)/86400.
-
-! initial and boundary conditions :
-      write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc
-      do l = 1, llm
-! Ligne du dessous à decommenter si on lit theta au lieu de temp
-       temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 
-!      temp(l) = t_mod(l) 
-       q(l,1) = qv_mod(l)
-       q(l,2) = 0.0
-!      print *,'read_forc: l,temp,q=',l,temp(l),q(l,1)
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       ug(l)=ug_dice(1)
-       vg(l)=vg_dice(1)
-       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!      omega(l) = w_mod(l)*(-rg*rho(l))
-       omega(l) = omega_mod(l)
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!on applique le forcage total au premier pas de temps
-!attention: signe different de toga
-       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)
-!forcage en th
-!       d_th_adv(l) = ht_mod(l)
-       d_q_adv(l,1) = hq_mod(l)
-       d_q_adv(l,2) = 0.0
-       dt_cooling(l)=0.
-      enddo     
-       write(*,*) 'Profil initial forcing DICE interpole temp39',temp(39)
-      
-
-!     ok_flux_surf=.false.
-      fsens=-1.*shf_dice(1)
-      flat=-1.*lhf_dice(1)
-! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 
-! le coefficient de trainee en surface cd**2=ustar*vent(k=1)
-! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface
-! MPL 05082013
-      ust=ustar_dice(1)
-      tg=tg_dice(1)
-      print *,'ust= ',ust
-      IF (tsurf .LE. 0.) THEN
-       tsurf= tg_dice(1)
-      ENDIF
-      psurf= psurf_dice(1)
-      solsw_in = (1.-albedo)/albedo*swup_dice(1)
-      sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1)
-      PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in
-      endif !forcing_dice
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from Arm_Cu case                   
-! For this case, ifa_armcu.txt contains sensible, latent heat fluxes
-! large scale advective forcing,radiative forcing 
-! and advective tendency of theta and qt to be applied 
-!---------------------------------------------------------------------
-
-      if (forcing_armcu) then
-! read armcu forcing :
-       write(*,*) 'Avant lecture Forcing Arm_Cu'
-      fich_armcu = './ifa_armcu.txt'
-      CALL read_armcu(fich_armcu,nlev_armcu,nt_armcu,                       &
-     & sens_armcu,flat_armcu,adv_theta_armcu,                               &
-     & rad_theta_armcu,adv_qt_armcu)
-       write(*,*) 'Forcing Arm_Cu lu'
-
-!----------------------------------------------------------------------
-! Read profiles from file: prof.inp.19 or prof.inp.40 
-! For this case, profiles are given for two vertical resolution
-! 19 or 40 levels
-!
-! Comment from: http://www.knmi.nl/samenw/eurocs/ARM/profiles.html
-! Note that the initial profiles contain no liquid water! 
-! (so potential temperature can be interpreted as liquid water 
-! potential temperature and water vapor as total water)
-! profiles are given at full levels
-!----------------------------------------------------------------------
-
-      call readprofile_armcu(nlev_max,kmax,height,play_mod,u_mod,           &
-     &           v_mod,theta_mod,t_mod,qv_mod,rv_mod,ap,bp)
-
-! time interpolation for initial conditions:
-      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
-
-      print *,'Avant interp_armcu_time'
-      print *,'daytime=',daytime
-      print *,'day1=',day1
-      print *,'annee_ref=',annee_ref
-      print *,'year_ini_armcu=',year_ini_armcu
-      print *,'day_ju_ini_armcu=',day_ju_ini_armcu
-      print *,'nt_armcu=',nt_armcu
-      print *,'dt_armcu=',dt_armcu
-      print *,'nlev_armcu=',nlev_armcu
-      CALL interp_armcu_time(daytime,day1,annee_ref                         &
-     &            ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu        &
-     &            ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu         &
-     &            ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof         &
-     &            ,adv_theta_prof,rad_theta_prof,adv_qt_prof)
-       write(*,*) 'Forcages interpoles dans temps'
-
-! No vertical interpolation if nlev imposed to 19 or 40
-! The vertical grid stops at 4000m # 600hPa
-      mxcalc=llm
-
-! initial and boundary conditions :
-!     tsurf = ts_prof
-! tsurf read in lmdz1d.def
-      write(*,*) 'Tsurf initiale: ',tsurf
-      do l = 1, llm
-       play(l)=play_mod(l)*100.
-       presnivs(l)=play(l)
-       zlay(l)=height(l)
-       temp(l) = t_mod(l)
-       teta(l)=theta_mod(l)
-       q(l,1) = qv_mod(l)/1000.
-! No liquid water in the initial profil
-       q(l,2) = 0.
-       u(l) = u_mod(l)
-       ug(l)= u_mod(l)
-       v(l) = v_mod(l)
-       vg(l)= v_mod(l)
-! Advective forcings are given in K or g/kg ... per HOUR
-!      IF(height(l).LT.1000) THEN
-!        d_th_adv(l) = (adv_theta_prof + rad_theta_prof)/3600.
-!        d_q_adv(l,1) = adv_qt_prof/1000./3600.
-!        d_q_adv(l,2) = 0.0
-!      ELSEIF (height(l).GE.1000.AND.height(l).LT.3000) THEN
-!        d_th_adv(l) = (adv_theta_prof + rad_theta_prof)*
-!    :               (1-(height(l)-1000.)/2000.)
-!        d_th_adv(l) = d_th_adv(l)/3600.
-!        d_q_adv(l,1) = adv_qt_prof*(1-(height(l)-1000.)/2000.)
-!        d_q_adv(l,1) = d_q_adv(l,1)/1000./3600.
-!        d_q_adv(l,2) = 0.0
-!      ELSE
-!        d_th_adv(l) = 0.0
-!        d_q_adv(l,1) = 0.0
-!        d_q_adv(l,2) = 0.0
-!      ENDIF
-      enddo
-! plev at half levels is given in proh.inp.19 or proh.inp.40 files
-      plev(1)= ap(llm+1)+bp(llm+1)*psurf
-      do l = 1, llm
-      plev(l+1) = ap(llm-l+1)+bp(llm-l+1)*psurf
-      print *,'Read_forc: l height play plev zlay temp',                    &
-     &   l,height(l),play(l),plev(l),zlay(l),temp(l)
-      enddo
-! For this case, fluxes are imposed
-       fsens=-1*sens_prof
-       flat=-1*flat_prof
-
-      endif ! forcing_armcu
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from transition case of Irina Sandu                  
-!---------------------------------------------------------------------
-
-      if (forcing_sandu) then
-       write(*,*) 'Avant lecture Forcing SANDU'
-
-! read sanduref forcing :
-      fich_sandu = './ifa_sanduref.txt'
-      CALL read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
-
-       write(*,*) 'Forcing SANDU lu'
-
-!----------------------------------------------------------------------
-! Read profiles from file: prof.inp.001 
-!----------------------------------------------------------------------
-
-      call readprofile_sandu(nlev_max,kmax,height,plev_profs,t_profs,       &
-     &           thl_profs,q_profs,u_profs,v_profs,                         &
-     &           w_profs,omega_profs,o3mmr_profs)
-
-! time interpolation for initial conditions:
-      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
-! ATTENTION, cet appel ne convient pas pour le cas SANDU !!
-! revoir 1DUTILS.h et les arguments
-
-      print *,'Avant interp_sandu_time'
-      print *,'daytime=',daytime
-      print *,'day1=',day1
-      print *,'annee_ref=',annee_ref
-      print *,'year_ini_sandu=',year_ini_sandu
-      print *,'day_ju_ini_sandu=',day_ju_ini_sandu
-      print *,'nt_sandu=',nt_sandu
-      print *,'dt_sandu=',dt_sandu
-      print *,'nlev_sandu=',nlev_sandu
-      CALL interp_sandu_time(daytime,day1,annee_ref                         &
-     &             ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu       &
-     &             ,nlev_sandu                                              &
-     &             ,ts_sandu,ts_prof)
-
-! vertical interpolation:
-      print *,'Avant interp_vertical: nlev_sandu=',nlev_sandu
-      CALL interp_sandu_vertical(play,nlev_sandu,plev_profs                 &
-     &         ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs           &
-     &         ,omega_profs,o3mmr_profs                                     &
-     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                       &
-     &         ,omega_mod,o3mmr_mod,mxcalc)
-       write(*,*) 'Profil initial forcing SANDU interpole'
-
-! initial and boundary conditions :
-      tsurf = ts_prof
-      write(*,*) 'SST initiale: ',tsurf
-      do l = 1, llm
-       temp(l) = t_mod(l)
-       tetal(l)=thl_mod(l)
-       q(l,1) = q_mod(l)
-       q(l,2) = 0.0
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       w(l) = w_mod(l)
-       omega(l) = omega_mod(l)
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-!?       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!?       omega2(l)=-rho(l)*omega(l)
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!      d_th_adv(l) = alpha*omega(l)/rcpd+vt_mod(l)
-!      d_q_adv(l,1) = vq_mod(l)
-       d_th_adv(l) = alpha*omega(l)/rcpd
-       d_q_adv(l,1) = 0.0
-       d_q_adv(l,2) = 0.0
-      enddo
-
-      endif ! forcing_sandu
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from Astex case
-!---------------------------------------------------------------------
-
-      if (forcing_astex) then
-       write(*,*) 'Avant lecture Forcing Astex'
-
-! read astex forcing :
-      fich_astex = './ifa_astex.txt'
-      CALL read_astex(fich_astex,nlev_astex,nt_astex,div_astex,ts_astex,    &
-     &  ug_astex,vg_astex,ufa_astex,vfa_astex)
-
-       write(*,*) 'Forcing Astex lu'
-
-!----------------------------------------------------------------------
-! Read profiles from file: prof.inp.001
-!----------------------------------------------------------------------
-
-      call readprofile_astex(nlev_max,kmax,height,plev_profa,t_profa,       &
-     &           thl_profa,qv_profa,ql_profa,qt_profa,u_profa,v_profa,      &
-     &           w_profa,tke_profa,o3mmr_profa)
-
-! time interpolation for initial conditions:
-      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
-! ATTENTION, cet appel ne convient pas pour le cas SANDU !!
-! revoir 1DUTILS.h et les arguments
-
-      print *,'Avant interp_astex_time'
-      print *,'daytime=',daytime
-      print *,'day1=',day1
-      print *,'annee_ref=',annee_ref
-      print *,'year_ini_astex=',year_ini_astex
-      print *,'day_ju_ini_astex=',day_ju_ini_astex
-      print *,'nt_astex=',nt_astex
-      print *,'dt_astex=',dt_astex
-      print *,'nlev_astex=',nlev_astex
-      CALL interp_astex_time(daytime,day1,annee_ref                         &
-     &             ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex       &
-     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex         &
-     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof    &
-     &             ,ufa_prof,vfa_prof)
-
-! vertical interpolation:
-      print *,'Avant interp_vertical: nlev_astex=',nlev_astex
-      CALL interp_astex_vertical(play,nlev_astex,plev_profa                 &
-     &         ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa                &
-     &         ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa               &
-     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod        &
-     &         ,tke_mod,o3mmr_mod,mxcalc)
-       write(*,*) 'Profil initial forcing Astex interpole'
-
-! initial and boundary conditions :
-      tsurf = ts_prof
-      write(*,*) 'SST initiale: ',tsurf
-      do l = 1, llm
-       temp(l) = t_mod(l)
-       tetal(l)=thl_mod(l)
-       q(l,1) = qv_mod(l)
-       q(l,2) = ql_mod(l)
-       u(l) = u_mod(l)
-       v(l) = v_mod(l)
-       w(l) = w_mod(l)
-       omega(l) = w_mod(l)
-!      omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-!      rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
-!      omega2(l)=-rho(l)*omega(l)
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!      d_th_adv(l) = alpha*omega(l)/rcpd+vt_mod(l)
-!      d_q_adv(l,1) = vq_mod(l)
-       d_th_adv(l) = alpha*omega(l)/rcpd
-       d_q_adv(l,1) = 0.0
-       d_q_adv(l,2) = 0.0
-      enddo
-
-      endif ! forcing_astex
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!---------------------------------------------------------------------
-! Forcing from standard case :
-!---------------------------------------------------------------------
-
-      if (forcing_case) then
-
-         write(*,*),'avant call read_1D_cas'
-         call read_1D_cas
-         write(*,*) 'Forcing read'
-
-!Time interpolation for initial conditions using TOGA interpolation routine
-         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
-      CALL interp_case_time(day,day1,annee_ref                &
-     &         ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_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                 &
-     &         ,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)
-
-! vertical interpolation using TOGA interpolation routine:
-!      write(*,*)'avant interp vert', t_prof
-      CALL interp_case_vertical(play,nlev_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           &
-     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
-!       write(*,*) 'Profil initial forcing case interpole',t_mod
-
-! initial and boundary conditions :
-!      tsurf = ts_prof_cas
-      ts_cur = ts_prof_cas 
-      psurf=plev_prof_cas(1)
-      write(*,*) 'SST initiale: ',tsurf
-      do l = 1, llm
-       temp(l) = t_mod_cas(l)
-       q(l,1) = q_mod_cas(l)
-       q(l,2) = 0.0
-       u(l) = u_mod_cas(l)
-       v(l) = v_mod_cas(l)
-       omega(l) = w_mod_cas(l)
-       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
-
-       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
-!on applique le forcage total au premier pas de temps
-!attention: signe different de toga
-       d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l))
-       d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l))
-       d_q_adv(l,2) = 0.0
-       d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l))
-       d_u_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l))
-      enddo     
-       
-      endif !forcing_case
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: LMDZ5/branches/testing/libf/phylmd/1Dconv.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/1Dconv.h	(revision 2274)
+++ 	(revision )
@@ -1,872 +1,0 @@
-        subroutine get_uvd(itap,dtime,file_forctl,file_fordat,                  &
-     &       ht,hq,hw,hu,hv,hthturb,hqturb,                                     &
-     &       Ts,imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)                                 
-!
-        implicit none
- 
-!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! cette routine permet d obtenir u_convg,v_convg,ht,hq et ainsi de
-! pouvoir calculer la convergence et le cisaillement dans la physiq
-!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-#include "YOMCST.h"
-
-      INTEGER klev
-      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
-      INTEGER JM(100) !pression en Pa au milieu de chaque couche GCM
-      REAL coef1(100) !coefficient d interpolation
-      REAL coef2(100) !coefficient d interpolation
-
-      INTEGER nblvlm !nombre de niveau de pression du mesoNH
-      REAL playm(100)  !pression en Pa au milieu de chaque couche Meso-NH
-      REAL hplaym(100) !pression en hPa milieux des couches Meso-NH
-
-      integer i,j,k,ll,in
-
-      CHARACTER*80 file_forctl,file_fordat
-
-      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
-      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
-
-!======================================================================
-! methode: on va chercher les donnees du mesoNH de meteo france, on y
-!          a acces a tout pas detemps grace a la routine rdgrads qui
-!          est une boucle lisant dans ces fichiers.
-!          Puis on interpole ces donnes sur les 11 niveaux du gcm et
-!          et sur les pas de temps de ce meme gcm
-!----------------------------------------------------------------------
-! input:
-!       pasmax     :nombre de pas de temps maximum du mesoNH
-!       dt         :pas de temps du meso_NH (en secondes)
-!----------------------------------------------------------------------
-      integer pasmax,dt
-      save pasmax,dt
-!----------------------------------------------------------------------
-! arguments:
-!           itap   :compteur de la physique(le nombre de ces pas est
-!                   fixe dans la subroutine calcul_ini_gcm de interpo
-!                   -lation
-!           dtime  :pas detemps du gcm (en secondes)
-!           ht     :convergence horizontale de temperature(K/s)
-!           hq     :    "         "       d humidite (kg/kg/s)
-!           hw     :vitesse verticale moyenne (m/s**2)
-!           hu     :convergence horizontale d impulsion le long de x
-!                  (kg/(m^2 s^2)
-!           hv     : idem le long de y.
-!           Ts     : Temperature de surface (K)
-!           imp_fcg: var. logical .eq. T si forcage en impulsion
-!           ts_fcg: var. logical .eq. T si forcage en Ts present dans fichier
-!           Tp_fcg: var. logical .eq. T si forcage donne en Temp potentielle
-!           Turb_fcg: var. logical .eq. T si forcage turbulent present dans fichier
-!----------------------------------------------------------------------
-        integer itap
-        real dtime
-        real ht(100)
-        real hq(100)
-        real hu(100)
-        real hv(100)
-        real hw(100)
-        real hthturb(100)
-        real hqturb(100)
-        real Ts, Ts_subr
-        logical imp_fcg
-        logical ts_fcg
-        logical Tp_fcg
-        logical Turb_fcg
-!----------------------------------------------------------------------
-! Variables internes de get_uvd (note : l interpolation temporelle
-! est faite entre les pas de temps before et after, sur les variables
-! definies sur la grille du SCM; on atteint exactement les valeurs Meso
-! aux milieux des pas de temps Meso)
-!     time0     :date initiale en secondes
-!     time      :temps associe a chaque pas du SCM
-!     pas       :numero du pas du meso_NH (on lit en pas : le premier pas
-!                 des donnees est duplique)
-!     pasprev   :numero du pas de lecture precedent
-!     htaft     :advection horizontale de temp. au pas de temps after
-!     hqaft     :    "         "      d humidite        "
-!     hwaft     :vitesse verticalle moyenne  au pas de temps after
-!     huaft,hvaft :advection horizontale d impulsion au pas de temps after
-!     tsaft     : surface temperature 'after time step'
-!     htbef     :idem htaft, mais pour le pas de temps before
-!     hqbef     :voir hqaft
-!     hwbef     :voir hwaft
-!     hubef,hvbef : idem huaft,hvaft, mais pour before
-!     tsbef     : surface temperature 'before time step'
-!----------------------------------------------------------------------
-        integer time0,pas,pasprev
-        save time0,pas,pasprev
-        real time
-        real htaft(100),hqaft(100),hwaft(100),huaft(100),hvaft(100)
-        real hthturbaft(100),hqturbaft(100)
-        real Tsaft
-        save htaft,hqaft,hwaft,huaft,hvaft,hthturbaft,hqturbaft
-        real htbef(100),hqbef(100),hwbef(100),hubef(100),hvbef(100)
-        real hthturbbef(100),hqturbbef(100)
-        real Tsbef
-        save htbef,hqbef,hwbef,hubef,hvbef,hthturbbef,hqturbbef
-!
-        real timeaft,timebef
-        save timeaft,timebef
-        integer temps
-        character*4 string
-!----------------------------------------------------------------------
-! variables arguments de la subroutine rdgrads
-!---------------------------------------------------------------------
-        integer icompt,icomp1 !compteurs de rdgrads
-        real z(100)         ! altitude (grille Meso)
-        real ht_mes(100)    !convergence horizontale de temperature
-                            !-(grille Meso)
-        real hq_mes(100)    !convergence horizontale d humidite
-                            !(grille Meso)
-        real hw_mes(100)    !vitesse verticale moyenne
-                            !(grille Meso)
-        real hu_mes(100),hv_mes(100)    !convergence horizontale d impulsion
-                                        !(grille Meso)
-        real hthturb_mes(100) !tendance horizontale de T_pot, due aux
-                              !flux turbulents
-        real hqturb_mes(100) !tendance horizontale d humidite, due aux
-                              !flux turbulents
-!
-!---------------------------------------------------------------------
-! variable argument de la subroutine copie
-!---------------------------------------------------------------------
-! SB        real pplay(100)    !pression en milieu de couche du gcm
-! SB                            !argument de la physique
-!---------------------------------------------------------------------
-! variables destinees a la lecture du pas de temps du fichier de donnees
-!---------------------------------------------------------------------
-       character*80 aaa,atemps,spaces,apasmax
-       integer nch,imn,ipa
-!---------------------------------------------------------------------
-!  procedures appelees
-        external rdgrads    !lire en iterant dans forcing.dat
-!---------------------------------------------------------------------
-               print*,'le pas itap est:',itap
-!*** on determine le pas du meso_NH correspondant au nouvel itap ***
-!*** pour aller chercher les champs dans rdgrads                 ***
-!
-        time=time0+itap*dtime
-!c        temps=int(time/dt+1)
-!c        pas=min(temps,pasmax)
-        temps = 1 + int((dt + 2*time)/(2*dt))
-        pas=min(temps,pasmax-1)
-             print*,'le pas Meso est:',pas
-!
-!
-!===================================================================
-!
-!*** on remplit les champs before avec les champs after du pas   ***
-!*** precedent en format gcm                                     ***
-        if(pas.gt.pasprev)then
-          do i=1,klev
-             htbef(i)=htaft(i)
-             hqbef(i)=hqaft(i)
-             hwbef(i)=hwaft(i)
-             hubef(i)=huaft(i)
-             hvbef(i)=hvaft(i)
-             hThTurbbef(i)=hThTurbaft(i)
-             hqTurbbef(i)=hqTurbaft(i)
-          enddo
-          tsbef = tsaft
-          timebef=pasprev*dt
-          timeaft=timebef+dt
-          icomp1 = nblvlm*4
-          IF (ts_fcg) icomp1 = icomp1 + 1
-          IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
-          IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
-          icompt = icomp1*pas
-         print *, 'imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt'
-         print *, imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt
-                       print*,'le pas pas est:',pas
-!*** on va chercher les nouveaux champs after dans toga.dat     ***
-!*** champs en format meso_NH                                   ***
-          open(99,FILE=file_fordat,FORM='UNFORMATTED',                        &
-     &             ACCESS='DIRECT',RECL=8)
-          call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes                &
-     &                  ,hu_mes,hv_mes,hthturb_mes,hqturb_mes                 &
-     &                  ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
-!
-
-               if(Tp_fcg) then
-!     (le forcage est donne en temperature potentielle)
-         do i = 1,nblvlm
-           ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
-         enddo
-               endif ! Tp_fcg
-        if(Turb_fcg) then
-         do i = 1,nblvlm
-           hThTurb_mes(i) = hThTurb_mes(i)*(hplaym(i)/1000.)**rkappa
-         enddo
-        endif  ! Turb_fcg
-!
-               print*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
-               print*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
-               print*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
-                  if(imp_fcg) then
-               print*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
-               print*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
-                  endif
-                  if(Turb_fcg) then
-               print*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
-               print*,'hqTurb_mes ',(hqTurb_mes(i),i=1,nblvlm)
-                  endif
-          IF (ts_fcg) print*,'ts_subr', ts_subr
-!*** on interpole les champs meso_NH sur les niveaux de pression***
-!*** gcm . on obtient le nouveau champ after                    ***
-            do k=1,klev
-             if (JM(k) .eq. 0) then
-         htaft(k)=              ht_mes(jm(k)+1)
-         hqaft(k)=              hq_mes(jm(k)+1)
-         hwaft(k)=              hw_mes(jm(k)+1)
-               if(imp_fcg) then
-           huaft(k)=              hu_mes(jm(k)+1)
-           hvaft(k)=              hv_mes(jm(k)+1)
-               endif ! imp_fcg
-               if(Turb_fcg) then
-           hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
-           hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
-               endif ! Turb_fcg
-             else ! JM(k) .eq. 0
-           htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
-           hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
-           hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
-               if(imp_fcg) then
-           huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
-           hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
-               endif ! imp_fcg
-               if(Turb_fcg) then
-           hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                            &
-     &               +coef2(k)*hThTurb_mes(jm(k)+1)
-           hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                             &
-     &               +coef2(k)*hqTurb_mes(jm(k)+1)
-               endif ! Turb_fcg
-             endif ! JM(k) .eq. 0
-            enddo
-            tsaft = ts_subr
-            pasprev=pas
-         else ! pas.gt.pasprev
-            print*,'timebef est:',timebef
-         endif ! pas.gt.pasprev    fin du bloc relatif au passage au pas
-                                  !de temps (meso) suivant
-!*** si on atteint le pas max des donnees experimentales ,on     ***
-!*** on conserve les derniers champs calcules                    ***
-      if(temps.ge.pasmax)then
-          do ll=1,klev
-               ht(ll)=htaft(ll)
-               hq(ll)=hqaft(ll)
-               hw(ll)=hwaft(ll)
-               hu(ll)=huaft(ll)
-               hv(ll)=hvaft(ll)
-               hThTurb(ll)=hThTurbaft(ll)
-               hqTurb(ll)=hqTurbaft(ll)
-          enddo
-          ts_subr = tsaft
-      else ! temps.ge.pasmax
-!*** on interpole sur les pas de temps de 10mn du gcm a partir   ***
-!** des pas de temps de 1h du meso_NH                            ***
-         do j=1,klev
-         ht(j)=((timeaft-time)*htbef(j)+(time-timebef)*htaft(j))/dt
-         hq(j)=((timeaft-time)*hqbef(j)+(time-timebef)*hqaft(j))/dt
-         hw(j)=((timeaft-time)*hwbef(j)+(time-timebef)*hwaft(j))/dt
-             if(imp_fcg) then
-         hu(j)=((timeaft-time)*hubef(j)+(time-timebef)*huaft(j))/dt
-         hv(j)=((timeaft-time)*hvbef(j)+(time-timebef)*hvaft(j))/dt
-             endif ! imp_fcg
-             if(Turb_fcg) then
-         hThTurb(j)=((timeaft-time)*hThTurbbef(j)                           &
-     &           +(time-timebef)*hThTurbaft(j))/dt
-         hqTurb(j)= ((timeaft-time)*hqTurbbef(j)                            &
-     &           +(time-timebef)*hqTurbaft(j))/dt
-             endif ! Turb_fcg
-         enddo
-         ts_subr = ((timeaft-time)*tsbef + (time-timebef)*tsaft)/dt
-       endif ! temps.ge.pasmax
-!
-        print *,' time,timebef,timeaft',time,timebef,timeaft
-        print *,' ht,htbef,htaft,hthturb,hthturbbef,hthturbaft'
-        do j= 1,klev
-           print *, j,ht(j),htbef(j),htaft(j),                              &
-     &             hthturb(j),hthturbbef(j),hthturbaft(j)
-        enddo
-        print *,' hq,hqbef,hqaft,hqturb,hqturbbef,hqturbaft'
-        do j= 1,klev
-           print *, j,hq(j),hqbef(j),hqaft(j),                              &
-     &             hqturb(j),hqturbbef(j),hqturbaft(j)
-        enddo
-!
-!-------------------------------------------------------------------
-!
-         IF (Ts_fcg) Ts = Ts_subr
-         return
-!
-!-----------------------------------------------------------------------
-! on sort les champs de "convergence" pour l instant initial 'in'
-! ceci se passe au pas temps itap=0 de la physique
-!-----------------------------------------------------------------------
-        entry get_uvd2(itap,dtime,file_forctl,file_fordat,                  &
-     &           ht,hq,hw,hu,hv,hThTurb,hqTurb,ts,                          &
-     &           imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)
-             print*,'le pas itap est:',itap
-!
-!===================================================================
-!
-       write(*,'(a)') 'OPEN '//file_forctl
-       open(97,FILE=file_forctl,FORM='FORMATTED')
-!
-!------------------
-      do i=1,1000
-      read(97,1000,end=999) string
- 1000 format (a4)
-      if (string .eq. 'TDEF') go to 50
-      enddo
- 50   backspace(97)
-!-------------------------------------------------------------------
-!   *** on lit le pas de temps dans le fichier de donnees ***
-!   *** "forcing.ctl" et pasmax                           ***
-!-------------------------------------------------------------------
-      read(97,2000) aaa
- 2000  format (a80)
-         print*,'aaa est',aaa
-      aaa=spaces(aaa,1)
-         print*,'aaa',aaa
-      call getsch(aaa,' ',' ',5,atemps,nch)
-         print*,'atemps est',atemps
-        atemps=atemps(1:nch-2)
-         print*,'atemps',atemps
-        read(atemps,*) imn
-        dt=imn*60
-         print*,'le pas de temps dt',dt
-      call getsch(aaa,' ',' ',2,apasmax,nch)
-        apasmax=apasmax(1:nch)
-        read(apasmax,*) ipa
-        pasmax=ipa
-         print*,'pasmax est',pasmax
-      CLOSE(97)
-!------------------------------------------------------------------
-! *** on lit le pas de temps initial de la simulation ***
-!------------------------------------------------------------------
-                  in=itap
-!c                  pasprev=in
-!c                  time0=dt*(pasprev-1)
-                  pasprev=in-1
-                  time0=dt*pasprev
-!
-          close(98)
-!
-      write(*,'(a)') 'OPEN '//file_fordat
-      open(99,FILE=file_fordat,FORM='UNFORMATTED',                          &
-     &          ACCESS='DIRECT',RECL=8)
-          icomp1 = nblvlm*4
-          IF (ts_fcg) icomp1 = icomp1 + 1
-          IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
-          IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
-          icompt = icomp1*(in-1)
-          call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes              &
-     &                   ,hu_mes,hv_mes,hthturb_mes,hqturb_mes              &
-     &                   ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
-          print *, 'get_uvd : rdgrads ->'
-          print *, tp_fcg
-!
-! following commented out because we have temperature already in ARM case
-!   (otherwise this is the potential temperature )
-!------------------------------------------------------------------------
-               if(Tp_fcg) then
-          do i = 1,nblvlm
-            ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
-          enddo
-               endif ! Tp_fcg
-           print*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
-           print*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
-           print*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
-              if(imp_fcg) then
-           print*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
-           print*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
-           print*,'t',ts_subr
-              endif ! imp_fcg
-              if(Turb_fcg) then
-                 print*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
-                 print*,'hqTurb ',     (hqTurb_mes(i),i=1,nblvlm)
-              endif ! Turb_fcg
-!----------------------------------------------------------------------
-! on a obtenu des champs initiaux sur les niveaux du meso_NH
-! on interpole sur les niveaux du gcm(niveau pression bien sur!)
-!-----------------------------------------------------------------------
-            do k=1,klev
-             if (JM(k) .eq. 0) then
-!FKC bug? ne faut il pas convertir tsol en tendance ????
-!RT bug taken care of by removing the stuff
-           htaft(k)=              ht_mes(jm(k)+1)
-           hqaft(k)=              hq_mes(jm(k)+1)
-           hwaft(k)=              hw_mes(jm(k)+1)
-               if(imp_fcg) then
-           huaft(k)=              hu_mes(jm(k)+1)
-           hvaft(k)=              hv_mes(jm(k)+1)
-               endif ! imp_fcg
-               if(Turb_fcg) then
-           hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
-           hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
-               endif ! Turb_fcg
-             else ! JM(k) .eq. 0
-           htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
-           hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
-           hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
-               if(imp_fcg) then
-           huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
-           hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
-               endif ! imp_fcg
-               if(Turb_fcg) then
-           hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                        &
-     &                  +coef2(k)*hThTurb_mes(jm(k)+1)
-           hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                         &
-     &                  +coef2(k)*hqTurb_mes(jm(k)+1)
-               endif ! Turb_fcg
-             endif ! JM(k) .eq. 0
-            enddo
-            tsaft = ts_subr
-! valeurs initiales des champs de convergence
-          do k=1,klev
-             ht(k)=htaft(k)
-             hq(k)=hqaft(k)
-             hw(k)=hwaft(k)
-                if(imp_fcg) then
-             hu(k)=huaft(k)
-             hv(k)=hvaft(k)
-                endif ! imp_fcg
-                if(Turb_fcg) then
-             hThTurb(k)=hThTurbaft(k)
-             hqTurb(k) =hqTurbaft(k)
-                endif ! Turb_fcg
-          enddo
-          ts_subr = tsaft
-          close(99)
-          close(98)
-!
-!-------------------------------------------------------------------
-!
-!
- 100      IF (Ts_fcg) Ts = Ts_subr
-        return
-!
-999     continue
-        stop 'erreur lecture, file forcing.ctl'
-        end
-
-      SUBROUTINE advect_tvl(dtime,zt,zq,vu_f,vv_f,t_f,q_f                   &
-     &                     ,d_t_adv,d_q_adv)
-      use dimphy
-      implicit none
-
-#include "dimensions.h"
-!cccc#include "dimphy.h"
-
-      integer k
-      real dtime, fact, du, dv, cx, cy, alx, aly
-      real zt(klev), zq(klev,3)
-      real vu_f(klev), vv_f(klev), t_f(klev), q_f(klev,3)
-
-      real d_t_adv(klev), d_q_adv(klev,3)
-
-! Velocity of moving cell
-      data cx,cy /12., -2./
-
-! Dimensions of moving cell
-      data alx,aly /100000.,150000./
-
-      do k = 1, klev
-            du = abs(vu_f(k)-cx)/alx
-            dv = abs(vv_f(k)-cy)/aly
-            fact = dtime *(du+dv-du*dv*dtime)
-            d_t_adv(k) = fact * (t_f(k)-zt(k))
-            d_q_adv(k,1) = fact * (q_f(k,1)-zq(k,1))
-            d_q_adv(k,2) = fact * (q_f(k,2)-zq(k,2))
-            d_q_adv(k,3) = fact * (q_f(k,3)-zq(k,3))
-      enddo
-
-      return
-      end
-
-      SUBROUTINE copie(klevgcm,playgcm,psolgcm,file_forctl)
-      implicit none
-
-!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! cette routine remplit les COMMON com1_phys_gcss et com2_phys_gcss.h
-!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-      INTEGER klev !nombre de niveau de pression du GCM
-      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
-      INTEGER JM(100)
-      REAL coef1(100)   !coefficient d interpolation
-      REAL coef2(100)   !coefficient d interpolation
-
-      INTEGER nblvlm !nombre de niveau de pression du mesoNH
-      REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH
-      REAL hplaym(100)!pression en hecto-Pa des milieux de couche Meso-NH
-
-      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
-      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
-
-      integer k,klevgcm
-      real playgcm(klevgcm) ! pression en milieu de couche du gcm
-      real psolgcm
-      character*80 file_forctl
-
-      klev = klevgcm
-
-!---------------------------------------------------------------------
-! pression au milieu des couches du gcm dans la physiq
-! (SB: remplace le call conv_lipress_gcm(playgcm) )
-!---------------------------------------------------------------------
-
-       do k = 1, klev
-        play(k) = playgcm(k)
-        print*,'la pression gcm est:',play(k)
-       enddo
-
-!----------------------------------------------------------------------
-! lecture du descripteur des donnees Meso-NH (forcing.ctl):
-!  -> nb niveaux du meso.NH (nblvlm) + pressions meso.NH
-! (on remplit le COMMON com2_phys_gcss)
-!----------------------------------------------------------------------
-
-      call mesolupbis(file_forctl)
-
-      print*,'la valeur de nblvlm est:',nblvlm
-
-!----------------------------------------------------------------------
-! etude de la correspondance entre les niveaux meso.NH et GCM;
-! calcul des coefficients d interpolation coef1 et coef2
-! (on remplit le COMMON com1_phys_gcss)
-!----------------------------------------------------------------------
-
-      call corresbis(psolgcm)
-
-!---------------------------------------------------------
-! TEST sur le remplissage de com1_phys_gcss et com2_phys_gcss:
-!---------------------------------------------------------
- 
-      write(*,*) ' '
-      write(*,*) 'TESTS com1_phys_gcss et com2_phys_gcss dans copie.F'
-      write(*,*) '--------------------------------------'
-      write(*,*) 'GCM: nb niveaux:',klev,' et pression, coeffs:'
-      do k = 1, klev
-      write(*,*) play(k), coef1(k), coef2(k)
-      enddo
-      write(*,*) 'MESO-NH: nb niveaux:',nblvlm,' et pression:'
-      do k = 1, nblvlm
-      write(*,*) playm(k), hplaym(k)
-      enddo
-      write(*,*) ' '
-
-      end
-      SUBROUTINE mesolupbis(file_forctl)
-      implicit none 
-!
-!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-!
-! Lecture descripteur des donnees MESO-NH (forcing.ctl):
-! -------------------------------------------------------
-!
-!     Cette subroutine lit dans le fichier de controle "essai.ctl"
-!     et affiche le nombre de niveaux du Meso-NH ainsi que les valeurs
-!     des pressions en milieu de couche du Meso-NH (en Pa puis en hPa).
-!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-!
-      INTEGER nblvlm !nombre de niveau de pression du mesoNH
-      REAL playm(100)  !pression en Pa milieu de chaque couche Meso-NH
-      REAL hplaym(100) !pression en hPa des milieux de couche Meso-NH
-      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
-
-      INTEGER i,lu,mlz,mlzh
- 
-      character*80 file_forctl
-
-      character*4 a
-      character*80 aaa,anblvl,spaces
-      integer nch
-
-      lu=9
-      open(lu,file=file_forctl,form='formatted')
-!
-      do i=1,1000
-      read(lu,1000,end=999) a
-      if (a .eq. 'ZDEF') go to 100
-      enddo
-!
- 100  backspace(lu)
-      print*,'  DESCRIPTION DES 2 MODELES : '
-      print*,' '
-!
-      read(lu,2000) aaa
- 2000  format (a80)
-       aaa=spaces(aaa,1)
-       call getsch(aaa,' ',' ',2,anblvl,nch)
-         read(anblvl,*) nblvlm
-
-!
-      print*,'nbre de niveaux de pression Meso-NH :',nblvlm
-      print*,' '
-      print*,'pression en Pa de chaque couche du meso-NH :'
-!
-      read(lu,*) (playm(mlz),mlz=1,nblvlm)
-!      Si la pression est en HPa, la multiplier par 100
-      if (playm(1) .lt. 10000.) then
-        do mlz = 1,nblvlm
-         playm(mlz) = playm(mlz)*100.
-        enddo
-      endif
-      print*,(playm(mlz),mlz=1,nblvlm)
-!
- 1000 format (a4)
- 1001 format(5x,i2)
-!
-      print*,' '
-      do mlzh=1,nblvlm
-      hplaym(mlzh)=playm(mlzh)/100.
-      enddo
-!
-      print*,'pression en hPa de chaque couche du meso-NH: '
-      print*,(hplaym(mlzh),mlzh=1,nblvlm)
-!
-      close (lu)
-      return
-!
- 999  stop 'erreur lecture des niveaux pression des donnees'
-      end
-
-      SUBROUTINE rdgrads(itape,icount,nl,z,ht,hq,hw,hu,hv,hthtur,hqtur,     &
-     &  ts_fcg,ts,imp_fcg,Turb_fcg)
-      IMPLICIT none
-      INTEGER itape,icount,icomp, nl
-      real z(nl),ht(nl),hq(nl),hw(nl),hu(nl),hv(nl)
-      real hthtur(nl),hqtur(nl)
-      real ts
-!
-      INTEGER k
-!
-      LOGICAL imp_fcg,ts_fcg,Turb_fcg
-!
-      icomp = icount
-!
-!
-         do k=1,nl
-            icomp=icomp+1
-            read(itape,rec=icomp)z(k)
-            print *,'icomp,k,z(k) ',icomp,k,z(k)
-         enddo
-         do k=1,nl
-            icomp=icomp+1
-            read(itape,rec=icomp)hT(k)
-             print*, hT(k), k
-         enddo
-         do k=1,nl
-            icomp=icomp+1
-            read(itape,rec=icomp)hQ(k)
-         enddo
-!
-             if(turb_fcg) then
-         do k=1,nl
-            icomp=icomp+1
-           read(itape,rec=icomp)hThTur(k)
-         enddo
-         do k=1,nl
-            icomp=icomp+1
-           read(itape,rec=icomp)hqTur(k)
-         enddo
-             endif
-         print *,' apres lecture hthtur, hqtur'
-!
-          if(imp_fcg) then
-
-         do k=1,nl
-            icomp=icomp+1
-           read(itape,rec=icomp)hu(k)
-         enddo
-         do k=1,nl
-            icomp=icomp+1
-            read(itape,rec=icomp)hv(k)
-         enddo
-
-          endif
-!
-         do k=1,nl
-            icomp=icomp+1
-            read(itape,rec=icomp)hw(k)
-         enddo
-!
-              if(ts_fcg) then
-         icomp=icomp+1
-         read(itape,rec=icomp)ts
-              endif
-!
-      print *,' rdgrads ->'
-
-      RETURN
-      END
-
-      SUBROUTINE corresbis(psol)
-      implicit none
-
-!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! Cette subroutine calcule et affiche les valeurs des coefficients
-! d interpolation qui serviront dans la formule d interpolation elle-
-! meme.
-!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-      INTEGER klev    !nombre de niveau de pression du GCM
-      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
-      INTEGER JM(100)
-      REAL coef1(100) !coefficient d interpolation
-      REAL coef2(100) !coefficient d interpolation
-
-      INTEGER nblvlm !nombre de niveau de pression du mesoNH
-      REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH
-      REAL hplaym(100)!pression en hPa des milieux de couche Meso-NH
-
-      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
-      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
-
-      REAL psol
-      REAL val
-      INTEGER k, mlz
-
-
-      do k=1,klev
-         val=play(k)
-       if (val .gt. playm(1)) then
-          mlz = 0
-          JM(1) = mlz
-          coef1(1)=(playm(mlz+1)-val)/(playm(mlz+1)-psol)
-          coef2(1)=(val-psol)/(playm(mlz+1)-psol)
-       else if (val .gt. playm(nblvlm)) then
-         do mlz=1,nblvlm
-          if (     val .le. playm(mlz).and. val .gt. playm(mlz+1))then
-           JM(k)=mlz
-           coef1(k)=(playm(mlz+1)-val)/(playm(mlz+1)-playm(mlz))
-           coef2(k)=(val-playm(mlz))/(playm(mlz+1)-playm(mlz))
-          endif
-         enddo
-       else
-         JM(k) = nblvlm-1
-         coef1(k) = 0.
-         coef2(k) = 0.
-       endif
-      enddo
-!
-!c      if (play(klev) .le. playm(nblvlm)) then
-!c         mlz=nblvlm-1
-!c         JM(klev)=mlz
-!c         coef1(klev)=(playm(mlz+1)-val)
-!c     *            /(playm(mlz+1)-playm(mlz))
-!c         coef2(klev)=(val-playm(mlz))
-!c     *            /(playm(mlz+1)-playm(mlz))
-!c      endif
-!
-      print*,' '
-      print*,'         INTERPOLATION  : '
-      print*,' '
-      print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
-      print*,(JM(k),k=1,klev)
-      print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
-      print*,(JM(k),k=1,klev)
-      print*,' '
-      print*,'vals du premier coef d"interpolation pour les 9 niveaux: '
-      print*,(coef1(k),k=1,klev)
-      print*,' '
-      print*,'valeurs du deuxieme coef d"interpolation pour les 9 niveaux:'
-      print*,(coef2(k),k=1,klev)
-!
-      return
-      end
-      SUBROUTINE GETSCH(STR,DEL,TRM,NTH,SST,NCH)
-!***************************************************************
-!*                                                             *
-!*                                                             *
-!* GETSCH                                                      *
-!*                                                             *
-!*                                                             *
-!* modified by :                                               *
-!***************************************************************
-!*   Return in SST the character string found between the NTH-1 and NTH
-!*   occurence of the delimiter 'DEL' but before the terminator 'TRM' in
-!*   the input string 'STR'. If TRM=DEL then STR is considered unlimited.
-!*   NCH=Length of the string returned in SST or =-1 if NTH is <1 or if
-!*   NTH is greater than the number of delimiters in STR.
-      IMPLICIT INTEGER (A-Z)
-      CHARACTER STR*(*),DEL*1,TRM*1,SST*(*)
-      NCH=-1
-      SST=' '
-      IF(NTH.GT.0) THEN
-        IF(TRM.EQ.DEL) THEN
-          LENGTH=LEN(STR)
-        ELSE
-          LENGTH=INDEX(STR,TRM)-1
-          IF(LENGTH.LT.0) LENGTH=LEN(STR)
-        ENDIF
-!*     Find beginning and end of the NTH DEL-limited substring in STR
-        END=-1
-        DO 1,N=1,NTH
-        IF(END.EQ.LENGTH) RETURN
-        BEG=END+2
-        END=BEG+INDEX(STR(BEG:LENGTH),DEL)-2
-        IF(END.EQ.BEG-2) END=LENGTH
-!*        PRINT *,'NTH,LENGTH,N,BEG,END=',NTH,LENGTH,N,BEG,END
-    1   CONTINUE
-        NCH=END-BEG+1
-        IF(NCH.GT.0) SST=STR(BEG:END)
-      ENDIF
-      END
-      CHARACTER*(*) FUNCTION SPACES(STR,NSPACE)
-!
-! CERN PROGLIB# M433    SPACES          .VERSION KERNFOR  4.14  860211
-! ORIG.  6/05/86 M.GOOSSENS/DD
-!
-!-    The function value SPACES returns the character string STR with
-!-    leading blanks removed and each occurence of one or more blanks
-!-    replaced by NSPACE blanks inside the string STR
-!
-      CHARACTER*(*) STR
-!
-      LENSPA = LEN(SPACES)
-      SPACES = ' '
-      IF (NSPACE.LT.0) NSPACE = 0
-      IBLANK = 1
-      ISPACE = 1
-  100 INONBL = INDEXC(STR(IBLANK:),' ')
-      IF (INONBL.EQ.0) THEN
-          SPACES(ISPACE:) = STR(IBLANK:)
-                                                    GO TO 999
-      ENDIF
-      INONBL = INONBL + IBLANK - 1
-      IBLANK = INDEX(STR(INONBL:),' ')
-      IF (IBLANK.EQ.0) THEN
-          SPACES(ISPACE:) = STR(INONBL:)
-                                                    GO TO 999
-      ENDIF
-      IBLANK = IBLANK + INONBL - 1
-      SPACES(ISPACE:) = STR(INONBL:IBLANK-1)
-      ISPACE = ISPACE + IBLANK - INONBL + NSPACE
-      IF (ISPACE.LE.LENSPA)                         GO TO 100
-  999 END
-      FUNCTION INDEXC(STR,SSTR)
-!
-! CERN PROGLIB# M433    INDEXC          .VERSION KERNFOR  4.14  860211
-! ORIG. 26/03/86 M.GOOSSENS/DD
-!
-!-    Find the leftmost position where substring SSTR does not match
-!-    string STR scanning forward
-!
-      CHARACTER*(*) STR,SSTR
-!
-      LENS   = LEN(STR)
-      LENSS  = LEN(SSTR)
-!
-      DO 10 I=1,LENS-LENSS+1
-          IF (STR(I:I+LENSS-1).NE.SSTR) THEN
-              INDEXC = I
-                                         GO TO 999
-          ENDIF
-   10 CONTINUE
-      INDEXC = 0
-!
-  999 END
Index: LMDZ5/branches/testing/libf/phylmd/calcul_STDlev.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/calcul_STDlev.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/calcul_STDlev.h	(revision 2298)
@@ -4,5 +4,5 @@
 !IM on initialise les variables 
 !
-        missing_val=nf90_fill_real
+!       missing_val=nf90_fill_real
 !
         CALL ini_undefSTD(itap,itapm1)
Index: LMDZ5/branches/testing/libf/phylmd/calcul_fluxs_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/calcul_fluxs_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/calcul_fluxs_mod.F90	(revision 2298)
@@ -5,12 +5,14 @@
 CONTAINS
   SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
-       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       tsurf, p1lay, cal, beta, cdragh, cdragq, ps, &
        precip_rain, precip_snow, snow, qsurf, &
-       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
-       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, gustiness, &
+       fqsat, petAcoef, peqAcoef, petBcoef, peqBcoef, &
        tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
     
     USE dimphy, ONLY : klon
     USE indice_sol_mod
+
+    INCLUDE "clesphys.h"
 
 ! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
@@ -26,5 +28,6 @@
 !   cal          capacite calorifique du sol
 !   beta         evap reelle
-!   coef1lay     coefficient d'echange
+!   cdragh       coefficient d'echange temperature
+!   cdragq       coefficient d'echange evaporation
 !   ps           pression au sol
 !   precip_rain  precipitations liquides
@@ -59,8 +62,9 @@
     REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
     REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
-    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, cdragh,cdragq
     REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow ! pas utiles
     REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
-    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay
+    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)
 
 ! Parametres entree-sorties
@@ -79,6 +83,6 @@
     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, zx_coef
-    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    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
@@ -125,5 +129,5 @@
     fluxlat=0.
     dflux_s = 0.
-    dflux_l = 0.	
+    dflux_l = 0.
 !
 ! zx_qs = qsat en kg/kg
@@ -154,8 +158,11 @@
        zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
        zx_qsat(i) = zx_qs
-       zx_coef(i) = coef1lay(i) * &
-            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
-            p1lay(i)/(RD*t1lay(i))
-       
+       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
 
@@ -168,5 +175,4 @@
        zx_sl(i) = RLVTT
        IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
-       zx_k1(i) = zx_coef(i)
     ENDDO
     
@@ -174,16 +180,18 @@
     DO i = 1, knon
 ! Q
-       zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
-       zx_mq(i) = beta(i) * zx_k1(i) * &
-            (peqAcoef(i) - zx_qsat(i) + &
-            zx_dq_s_dt(i) * tsurf(i)) &
+       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_k1(i) * (-1. * zx_dq_s_dt(i)) &
+       zx_nq(i) = beta(i) * zx_coefq(i) * (- fqsat * zx_dq_s_dt(i)) &
             / zx_oq(i)
        
 ! H
-       zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
-       zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
-       zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+       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
@@ -244,5 +252,5 @@
 !
   SUBROUTINE calcul_flux_wind(knon, dtime, &
-       u0, v0, u1, v1, cdrag_m, &
+       u0, v0, u1, v1, gustiness, cdrag_m, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
        p1lay, t1lay, &
@@ -251,4 +259,5 @@
     USE dimphy
     INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
 
 ! Input arguments
@@ -257,5 +266,5 @@
     REAL, INTENT(IN)                     :: dtime
     REAL, DIMENSION(klon), INTENT(IN)    :: u0, v0  ! u and v at niveau 0
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1  ! u and v at niveau 1
+    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
@@ -277,5 +286,5 @@
 !****************************************************************************************
     DO i=1,knon
-       mod_wind = 1.0 + SQRT((u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
+       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 )
Index: LMDZ5/branches/testing/libf/phylmd/carbon_cycle_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/carbon_cycle_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/carbon_cycle_mod.F90	(revision 2298)
@@ -157,5 +157,6 @@
     itc=0
     DO it=1,nbtr
-       iiq=niadv(it+2)
+!!       iiq=niadv(it+2)                                                            ! jyg
+       iiq=niadv(it+nqo)                                                            ! jyg
        
        SELECT CASE(tname(iiq))
Index: LMDZ5/branches/testing/libf/phylmd/cdrag.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cdrag.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cdrag.F90	(revision 2298)
@@ -4,5 +4,5 @@
  SUBROUTINE cdrag( knon,  nsrf,   &
      speed, t1,    q1,    zgeop1, &
-     psol,  tsurf, qsurf, rugos,  &
+     psol,  tsurf, qsurf, z0m, z0h,  &
      pcfm,  pcfh,  zri,   pref )
 
@@ -45,5 +45,5 @@
 ! tsurf---input-R- temperature de l'air a la surface 
 ! qsurf---input-R- humidite de l'air a la surface
-! rugos---input-R- rugosite
+! z0m, z0h---input-R- rugosite
 !! u1, v1 are removed, speed is used. Fuxing WANG, 04/03/2015,
 !! u1------input-R- vent zonal au 1er niveau du modele
@@ -71,5 +71,5 @@
   REAL, DIMENSION(klon), INTENT(IN)        :: tsurf ! Surface temperature (K)
   REAL, DIMENSION(klon), INTENT(IN)        :: qsurf ! Surface humidity (Kg/Kg)
-  REAL, DIMENSION(klon), INTENT(IN)        :: rugos ! Rugosity at surface (m) 
+  REAL, DIMENSION(klon), INTENT(IN)        :: z0m, z0h ! Rugosity at surface (m) 
 !  paprs, pplay u1, v1: to be deleted
 !  they were in the old clcdrag. Fuxing WANG, 04/03/2015
@@ -113,5 +113,5 @@
   REAL, DIMENSION(klon) :: zcfh1, zcfh2 ! Drag coefficient for heat flux
   LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
-  REAL, DIMENSION(klon) :: zcdn         ! Drag coefficient in neutral conditions
+  REAL, DIMENSION(klon) :: zcdn_m, zcdn_h         ! Drag coefficient in neutral conditions
 !
 ! Fonctions thermodynamiques et fonctions d'instabilite
@@ -174,5 +174,9 @@
           *(1.+RETV*max(q1(i),0.0)) ! negative q1 set to zero
      zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
-     zcdn(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2
+
+
+! Coefficients CD neutres pour m et h
+     zcdn_m(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*z0m(i))))**2
+     zcdn_h(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*z0h(i))))**2
 
      IF (zri(i) .GT. 0.) THEN      ! situation stable
@@ -181,33 +185,35 @@
            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
+           zcfm1(i) = zcdn_m(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
+           zcfh1(i) = f_cdrag_ter * zcdn_h(i) * frih
+           IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn_h(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))
+           pcfm(i) = zcdn_m(i)* fsta(zri(i))
+           pcfh(i) = zcdn_h(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)
+           zucf = 1./(1.+3.0*CB*CC*zcdn_m(i)*SQRT(ABS(zri(i)) &
+                *(1.0+zgeop1(i)/(RG*z0m(i)))))
+           zcfm2(i) = zcdn_m(i)*amax1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
+!!$ PB     zcfh2(i) = zcdn_h(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
+           zcfh2(i) = f_cdrag_ter*zcdn_h(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))
+           pcfm(i) = zcdn_m(i)* fins(zri(i))
+           pcfh(i) = zcdn_h(i)* fins(zri(i))
         ENDIF
-! cdrah sur l'ocean cf. Miller et al. (1992)
-        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)
+        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_m(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+           IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn_h(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
      ENDIF
   END DO
Index: LMDZ5/branches/testing/libf/phylmd/change_srf_frac_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/change_srf_frac_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/change_srf_frac_mod.F90	(revision 2298)
@@ -12,8 +12,6 @@
 
   SUBROUTINE change_srf_frac(itime, dtime, jour, &
-!albedo SB >>>
-!       pctsrf, alb1, alb2, tsurf, ustar, u10m, v10m, pbl_tke)
-        pctsrf, alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
-!albedo SB <<<
+        pctsrf, evap, z0m, z0h, agesno,              &
+        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
    
 
@@ -54,7 +52,7 @@
    
     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,nbsrf), INTENT(INOUT) :: alb1   ! albedo first interval in SW spektrum
-!   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2   ! albedo second interval in SW spektrum
     REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
 !albedo SB <<<
@@ -176,10 +174,7 @@
 !****************************************************************************************
 
-!albedo SB >>>
-! CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, ustar,
-! u10m, v10m, pbl_tke)
-       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
-!albedo SB <<<
-
+       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
+           evap, z0m, z0h, agesno,                                &
+           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
 
 
Index: LMDZ5/branches/testing/libf/phylmd/clcdrag.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/clcdrag.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/clcdrag.F90	(revision 2298)
@@ -129,6 +129,9 @@
            pcfh(i) = zcdn(i)* fins(zri(i))
         ENDIF
-        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)
+        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
Index: LMDZ5/branches/testing/libf/phylmd/clesphys.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/clesphys.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/clesphys.h	(revision 2298)
@@ -44,6 +44,10 @@
 ! Frottement au sol (Cdrag)
        Real f_cdrag_ter,f_cdrag_oce
+       REAL min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce
+       REAL z0m_seaice,z0h_seaice
+       INTEGER iflag_gusts,iflag_z0_oce
+
 ! Rugoro
-       Real f_rugoro
+       Real f_rugoro,z0min
 
 !IM lev_histhf  : niveau sorties 6h
@@ -91,5 +95,7 @@
      &     , cdmmax, cdhmax, ksta, ksta_ter, f_ri_cd_min                &
      &     , fmagic, pmagic                                             &
-     &     , f_cdrag_ter,f_cdrag_oce,f_rugoro                           &
+     &     , f_cdrag_ter,f_cdrag_oce,f_rugoro,z0min                     &
+     &     , min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce   &
+     &     , z0m_seaice,z0h_seaice                                      &
      &     , pasphys            , freq_outNMC, freq_calNMC              &
      &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
@@ -115,4 +121,5 @@
      &     , ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP                     &
      &     , ip_ebil_phy                                                &
+     &     , iflag_gusts ,iflag_z0_oce                                  &
      &     , ok_lic_melt,           aer_type                            &
      &     , iflag_rrtm, ok_strato,ok_hines, ok_qch4                    &
Index: LMDZ5/branches/testing/libf/phylmd/cloudth.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cloudth.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cloudth.F90	(revision 2298)
@@ -5,4 +5,5 @@
 
 
+      USE IOIPSL, ONLY : getin
       IMPLICIT NONE
 
@@ -39,5 +40,5 @@
       
       
-      REAL sigma1(ngrid,klev)                                                         
+      REAL sigma1(ngrid,klev)
       REAL sigma2(ngrid,klev)
       REAL qlth(ngrid,klev)
@@ -48,5 +49,5 @@
       REAL ctot(ngrid,klev)
       REAL rneb(ngrid,klev)
-      REAL t(ngrid,klev)                                                                  
+      REAL t(ngrid,klev)
       REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
       REAL rdd,cppd,Lv
@@ -62,18 +63,39 @@
       REAL erf
 
-
-
-
-
-!      print*,ngrid,klev,ind1,ind2,ztv(ind1,ind2),po(ind1),zqta(ind1,ind2), &
-!     &       fraca(ind1,ind2),zpspsk(ind1,ind2),paprs(ind1,ind2),ztla(ind1,ind2),zthl(ind1,ind2), &
-!     &       'verif'
-
-
-!      LOGICAL active(ngrid)   
-      
-!-----------------------------------------------------------------------------------------------------------------
+      REAL, SAVE :: iflag_cloudth_vert, iflag_cloudth_vert_omp=0
+
+
+      LOGICAL, SAVE :: first=.true.
+
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Astuce pour gérer deux versions de cloudth en attendant
+! de converger sur une version nouvelle
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IF (first) THEN
+     !$OMP MASTER
+     CALL getin('iflag_cloudth_vert',iflag_cloudth_vert_omp)
+     !$OMP END MASTER
+     !$OMP BARRIER
+     iflag_cloudth_vert=iflag_cloudth_vert_omp
+      first=.false.
+      ENDIF
+       IF (iflag_cloudth_vert==1) THEN
+       CALL cloudth_vert(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
+     &           ratqs,zqs,t)
+       RETURN
+       ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+!-------------------------------------------------------------------------------
 ! Initialisation des variables r?elles
-!-----------------------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
       sigma1(:,:)=0.
       sigma2(:,:)=0.
@@ -96,7 +118,7 @@
 
 
-!------------------------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
 ! Calcul de la fraction du thermique et des ?cart-types des distributions
-!------------------------------------------------------------------------------------------------------------------                 
+!-------------------------------------------------------------------------------                 
       do ind1=1,ngrid
 
@@ -139,7 +161,7 @@
       
 
-!-----------------------------------------------------------------------------------------------------------------
+!------------------------------------------------------------------------------
 ! 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)
@@ -155,7 +177,7 @@
 !      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)
@@ -176,5 +198,5 @@
 !      print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha'
 
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       if (ctot(ind1,ind2).lt.1.e-10) then
       ctot(ind1,ind2)=0.
@@ -242,9 +264,285 @@
 
 
-
-
-                                                                            
-
-
-
-
+!===========================================================================
+     SUBROUTINE cloudth_vert(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
+     &           ratqs,zqs,t)
+
+
+      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"
+#include "iniprint.h"
+#include "thermcell.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 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 alpha,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
+
+
+
+
+
+!------------------------------------------------------------------------------
+! 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)   
+!      ctot(ind1,ind2)=alpha*cth(ind1,ind2)+(1.-1.*alpha)*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)
+!      qltot(ind1,ind2)=alpha*qlth(ind1,ind2)+(1.-1.*alpha)*qlenv(ind1,ind2)
+     
+
+!      print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha'
+
+
+!-------------------------------------------------------------------------------
+!  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)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      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
Index: LMDZ5/branches/testing/libf/phylmd/coef_diff_turb_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/coef_diff_turb_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/coef_diff_turb_mod.F90	(revision 2298)
@@ -13,5 +13,5 @@
 !
   SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
-       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
        ycoefm, ycoefh ,yq2)
  
@@ -34,5 +34,5 @@
     REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
     REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
-    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yqsurf
     REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
 
@@ -70,5 +70,5 @@
     CALL coefkz(nsrf, knon, ypaprs, ypplay, &
          ksta, ksta_ter, &
-         yts, yrugos, yu, yv, yt, yq, &
+         yts, yu, yv, yt, yq, &
          yqsurf, &
          ycoefm, ycoefh)
@@ -181,5 +181,5 @@
   SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
        ksta, ksta_ter, &
-       ts, rugos, &
+       ts, &
        u,v,t,q, &
        qsurf, &
@@ -200,5 +200,4 @@
 ! pplay----input-R- pression au milieu de chaque couche (en Pa)
 ! ts-------input-R- temperature du sol (en Kelvin)
-! rugos----input-R- longeur de rugosite (en m)
 ! u--------input-R- vitesse u
 ! v--------input-R- vitesse v
@@ -223,5 +222,4 @@
     REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
     REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
-    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
     REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
 
Index: LMDZ5/branches/testing/libf/phylmd/compar1d.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/compar1d.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/compar1d.h	(revision 2298)
@@ -9,5 +9,5 @@
       real :: tsurf
       real :: rugos
-      real :: qsol(1:2)
+      real :: xqsol(1:2)
       real :: qsurf
       real :: psurf
@@ -32,5 +32,5 @@
       common/com_par1d/                                                 &
      & nat_surf,tsurf,rugos,                                            &
-     & qsol,qsurf,psurf,zsurf,albedo,time,time_ini,xlat,xlon,airefi,    &
+     & xqsol,qsurf,psurf,zsurf,albedo,time,time_ini,xlat,xlon,airefi,   &
      & wtsurf,wqsurf,restart_runoff,xagesno,qsolinp,zpicinp,            &
      & forcing_type,tend_u,tend_v,tend_w,tend_t,tend_q,tend_rayo,       &
Index: LMDZ5/branches/testing/libf/phylmd/concvl.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/concvl.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/concvl.F90	(revision 2298)
@@ -1,4 +1,4 @@
 SUBROUTINE concvl(iflag_clos, &
-                  dtime, paprs, pplay, &
+                  dtime, paprs, pplay, k_upper_cv, &
                   t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
                   Ale, Alp, sig1, w01, &
@@ -88,4 +88,5 @@
 
   REAL dtime, paprs(klon, klev+1), pplay(klon, klev)
+  INTEGER k_upper_cv
   REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
   REAL t_wake(klon, klev), q_wake(klon, klev)
@@ -214,4 +215,7 @@
   include "FCTTRE.h"
   include "iniprint.h"
+!jyg<
+  include "conema3.h"
+!>jyg
 
   IF (first) THEN
@@ -307,5 +311,8 @@
 
   em_sig1feed = 1.
-  em_sig2feed = 0.97
+!jyg<
+!  em_sig2feed = 0.97
+  em_sig2feed = cvl_sig2feed
+!>jyg
 ! em_sig2feed = 0.8
 ! Relative Weight densities
@@ -399,7 +406,7 @@
 !LF   necessary for gathered fields
     nloc = klon
-    CALL cva_driver(klon, klev, klev+1, ntra, nloc, &
+    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, &
+                    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, &
Index: LMDZ5/branches/testing/libf/phylmd/conema3.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/conema3.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/conema3.h	(revision 2298)
@@ -4,14 +4,21 @@
 !
       real epmax             ! 0.993
+!jyg<
+      REAL  cvl_comp_threshold     ! 0.
+!>jyg
       logical ok_adj_ema      ! F
       integer iflag_clw      ! 0
       integer iflag_cvl_sigd
-      real sig1feed      ! 1.
-      real sig2feed      ! 0.95
+      real cvl_sig2feed      ! 0.97
 
-      common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
-      common/comconema2/iflag_cvl_sigd
+!jyg<
+!!      common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
+!!      common/comconema2/iflag_cvl_sigd
+      common/comconema1/epmax, cvl_comp_threshold, cvl_sig2feed
+      common/comconema2/iflag_cvl_sigd, iflag_clw, ok_adj_ema
+!>jyg
 
 !      common/comconema/epmax,ok_adj_ema,iflag_clw
 !$OMP THREADPRIVATE(/comconema1/)
 !$OMP THREADPRIVATE(/comconema2/)
+
Index: LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90	(revision 2298)
@@ -40,4 +40,5 @@
     include "thermcell.h"
     include "iniprint.h"
+
 
     !IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
@@ -117,5 +118,8 @@
 
     Real,SAVE           :: f_cdrag_ter_omp,f_cdrag_oce_omp
-    Real,SAVE           :: f_rugoro_omp   
+    Real,SAVE           :: f_rugoro_omp   , z0min_omp
+    Real,SAVE           :: z0m_seaice_omp,z0h_seaice_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
 
     ! Local
@@ -142,4 +146,5 @@
     INTEGER, SAVE :: iflag_mix_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
@@ -188,4 +193,6 @@
     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
@@ -213,4 +220,5 @@
     !-----------------------------------------------------------------
 
+     print*,'CONFPHYS ENTREE'
     !$OMP MASTER 
     !Config Key  = type_ocean 
@@ -760,4 +768,20 @@
     ! 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
@@ -1645,31 +1669,46 @@
     !
     !
+    print*,'CONFPHYS OOK avant drag_ter'
     !
     ! PARAMETRES CDRAG
-    !
-    !Config Key  = f_cdrag_ter
-    !Config Desc =
-    !Config Def  = 0.8
-    !Config Help =
     !
     f_cdrag_ter_omp = 0.8
     call getin('f_cdrag_ter',f_cdrag_ter_omp)
     !
-    !Config Key  = f_cdrag_oce
-    !Config Desc =
-    !Config Def  = 0.8
-    !Config Help =
-    !
     f_cdrag_oce_omp = 0.8
     call getin('f_cdrag_oce',f_cdrag_oce_omp)
     !
-    ! RUGORO
-    !Config Key  = f_rugoro
-    !Config Desc =
-    !Config Def  = 0.
-    !Config Help =
-    !
+
+! 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)
+    !
+    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)
+
     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
@@ -1751,4 +1790,13 @@
     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)
 
     !
@@ -2018,9 +2066,26 @@
     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
     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
+
     f_rugoro=f_rugoro_omp
+
+    z0min=z0min_omp
     supcrit1 = supcrit1_omp
     supcrit2 = supcrit2_omp
@@ -2031,4 +2096,5 @@
     gammas = gammas_omp
     Fmax = Fmax_omp
+    tmax_fonte_cv = tmax_fonte_cv_omp
     alphas = alphas_omp
     ok_strato = ok_strato_omp
@@ -2105,4 +2171,6 @@
     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
@@ -2210,4 +2278,5 @@
     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
@@ -2218,4 +2287,5 @@
     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
Index: LMDZ5/branches/testing/libf/phylmd/cosp/MISR_simulator.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/MISR_simulator.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/MISR_simulator.F	(revision 2298)
@@ -0,0 +1,460 @@
+! 
+! 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:
+! 
+!     * 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 University of Washington 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 MISR_simulator(
+     &     npoints,
+     &     nlev,
+     &     ncol,
+     &     sunlit,
+     & 	   zfull,
+     &	   at,
+     &     dtau_s,
+     &	   dtau_c,
+     &	   frac_out,
+     & 	   fq_MISR_TAU_v_CTH,
+     &	   dist_model_layertops,
+     & 	   MISR_mean_ztop,
+     &     MISR_cldarea
+     & )
+	
+
+      implicit none
+      integer n_MISR_CTH
+      parameter(n_MISR_CTH=16)
+         
+!     -----
+!     Input 
+!     -----
+
+      INTEGER npoints                   !  if ncol ==1, the number of model points in the horizontal grid  
+      				        !   else 	the number of GCM grid points
+      				        
+      INTEGER nlev                      !  number of model vertical levels
+      
+      INTEGER ncol                      !  number of model sub columns 
+      					!  (must already be generated in via scops and passed to this
+      					!   routine via the variable frac_out )
+  
+      INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
+
+      REAL zfull(npoints,nlev)	      	!  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 (closest point to surface)  
+
+      REAL at(npoints,nlev)             !  temperature in each model level (K)
+ 
+      REAL dtau_s(npoints,nlev)         !  visible wavelength cloud optical depth ... for "stratiform" condensate
+                                        !  NOTE:  this the cloud optical depth of only the
+					!	  the model cell (i,j)
+					
+      REAL dtau_c(npoints,nlev)         !  visible wavelength cloud optical depth ... for "convective" condensate
+                                        !  NOTE:  this the cloud optical depth of only the
+					!	  the model cell (i,j)
+                                     
+      REAL frac_out(npoints,ncol,nlev)  !  NOTE: only need if columns>1 ... subgrid scheme in use.
+                                 
+!     ------
+!     Outputs
+!     ------
+       		
+      REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH)      
+      REAL dist_model_layertops(npoints,n_MISR_CTH)
+      REAL MISR_cldarea(npoints)		       ! fractional area coverged by clouds 
+      REAL MISR_mean_ztop(npoints)		       ! mean cloud top hieght(m) MISR would observe
+      						       ! NOTE: == 0 if area ==0
+      						
+
+!     ------
+!     Working variables 
+!     ------
+
+      REAL tau(npoints,ncol) 		! total column optical depth ... 
+
+      INTEGER j,ilev,ilev2,ibox
+      INTEGER itau
+         
+      LOGICAL box_cloudy(npoints,ncol)
+      
+      real isccp_taumin
+      real boxarea
+      real tauchk
+      REAL box_MISR_ztop(npoints,ncol)	! cloud top hieght(m) MISR would observe
+      
+      integer thres_crossed_MISR 
+      integer loop,iMISR_ztop
+      
+      real dtau, cloud_dtau, MISR_penetration_height,ztest     
+      
+      real MISR_CTH_boundaries(n_MISR_CTH+1)
+      
+      DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3,
+     c				      4, 5, 7, 9, 11, 13, 15, 17, 99 /
+      
+      DATA isccp_taumin / 0.3 /
+    
+      tauchk = -1.*log(0.9999999)
+    	
+      !
+      !	For each GCM cell or horizontal model grid point ...
+      !	
+      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*(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,n_MISR_CTH
+		
+			if ( ztest .gt.
+     &				  1000*MISR_CTH_boundaries(loop+1) ) then
+	    
+  				iMISR_ztop=loop+1
+   			endif
+		enddo
+
+		dist_model_layertops(j,iMISR_ztop)=
+     &			dist_model_layertops(j,iMISR_ztop)+1
+	 enddo
+	
+	
+         !
+         ! compute total cloud optical depth for each column
+         !       
+         do ibox=1,ncol     
+	   
+	    ! Initialize tau to zero in each subcolum
+      	    tau(j,ibox)=0. 
+	    box_cloudy(j,ibox)=.false.
+	    box_MISR_ztop(j,ibox)=0  
+	    
+	    ! initialize threshold detection for each sub column 
+	    thres_crossed_MISR=0;
+	   
+	    do ilev=1,nlev
+     
+     		 dtau=0
+     		 
+     		 if (frac_out(j,ibox,ilev).eq.1) then
+                        dtau = dtau_s(j,ilev)
+                 endif
+                 
+                 if (frac_out(j,ibox,ilev).eq.2) then
+                        dtau = dtau_c(j,ilev)
+                 end if	
+                 
+        	 tau(j,ibox)=tau(j,ibox)+ dtau
+        	  
+        	    	 
+		! NOW for MISR ..
+		! if there a cloud ... start the counter ... store this height
+		if(thres_crossed_MISR .eq. 0 .and. dtau .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 .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
+			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.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
+			
+				if(dtau .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*(zfull(j,ilev)+zfull(j,ilev-1)) - 
+     &					   0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
+     &					/dtau 
+				endif	
+
+				box_MISR_ztop(j,ibox)=MISR_penetration_height
+				
+			endif
+		
+			! check for a distinctive water layer
+			if(dtau .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 seen anything else ... set current point as CTH level
+			if(tau(j,ibox) .gt. 5) then	
+
+				thres_crossed_MISR=99			
+			endif
+
+		endif ! MISR CTH booundary not set
+		
+      	    enddo  !ilev - loop over vertical levesl
+	
+	    ! written by roj 5/2006
+	    ! 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( tau(j,ibox) .gt. 0.5) then
+
+			! keep MISR detected CTH
+			
+		elseif(tau(j,ibox) .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
+	if(ncol.eq.1) then
+	
+	   ! adjust based on neightboring points ... i.e. only 2D grid was input
+           do j=2,npoints-1
+			
+			if(box_MISR_ztop(j-1,1).gt.0 .and. 
+     &			   box_MISR_ztop(j+1,1).gt.0 	   ) then
+
+				if( 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
+
+			endif
+         enddo
+      else
+         
+         ! adjust based on neighboring subcolumns ....
+         do ibox=2,ncol-1
+			
+			if(box_MISR_ztop(1,ibox-1).gt.0 .and. 
+     &			   box_MISR_ztop(1,ibox+1).gt.0 	   ) then
+
+				if( abs( box_MISR_ztop(1,ibox-1) -  
+     &				  	 box_MISR_ztop(1,ibox+1) ) .lt. 500 
+     & 				.and.
+     &					 box_MISR_ztop(1,ibox) .lt. 
+     &					 box_MISR_ztop(1,ibox+1)     ) then
+			
+					box_MISR_ztop(1,ibox) =
+     &						box_MISR_ztop(1,ibox+1)    
+				endif
+
+			endif
+         enddo
+      
+      endif
+
+        !     
+	!     DETERMINE CLOUD TYPE FREQUENCIES
+	!
+	!     Now that ztop and tau have been determined, 
+	!     determine amount of each cloud type
+      boxarea=1./real(ncol)  
+      do j=1,npoints 
+
+         ! reset frequencies -- modified loop structure, roj 5/2006 
+         do ilev=1,7  ! "tau loop"	
+            do  ilev2=1,n_MISR_CTH	    		        
+      		fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.     
+            enddo
+      	 enddo
+      	   
+	 MISR_cldarea(j)=0.
+      	 MISR_mean_ztop(j)=0.
+
+         do ibox=1,ncol
+
+            if (tau(j,ibox) .gt. (tauchk)) then
+               box_cloudy(j,ibox)=.true.
+            endif
+  
+  	    itau = 0
+  	    
+            if (box_cloudy(j,ibox)) then
+	
+	      !determine optical depth category
+              if (tau(j,ibox) .lt. isccp_taumin) then
+                  itau=1
+              else if (tau(j,ibox) .ge. isccp_taumin                                    
+     &          .and. tau(j,ibox) .lt. 1.3) then
+                  itau=2
+              else if (tau(j,ibox) .ge. 1.3 
+     &          .and. tau(j,ibox) .lt. 3.6) then
+                  itau=3
+              else if (tau(j,ibox) .ge. 3.6 
+     &          .and. tau(j,ibox) .lt. 9.4) then
+                  itau=4
+              else if (tau(j,ibox) .ge. 9.4 
+     &          .and. tau(j,ibox) .lt. 23.) then
+                  itau=5
+              else if (tau(j,ibox) .ge. 23. 
+     &          .and. tau(j,ibox) .lt. 60.) then
+                  itau=6
+              else if (tau(j,ibox) .ge. 60.) then
+                  itau=7
+              endif
+              
+	   endif  
+
+	   ! update MISR histograms and summary metrics - roj 5/2005
+	   if (sunlit(j).eq.1) then 
+              	     
+              !if cloudy added by roj 5/2005
+	      if( box_MISR_ztop(j,ibox).eq.0) then
+	      
+			! no cloud detected
+			iMISR_ztop=0
+
+	      elseif( box_MISR_ztop(j,ibox).eq.-1) then
+
+			! cloud can be detected but too thin to get CTH
+			iMISR_ztop=1    
+
+     			fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
+     &          		fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
+
+	      else
+	      	
+			!
+			! determine index for MISR bin set
+			!
+
+			iMISR_ztop=2
+			
+			do loop=2,n_MISR_CTH
+		
+				if ( box_MISR_ztop(j,ibox) .gt.
+     &				  1000*MISR_CTH_boundaries(loop+1) ) then
+	    
+				  iMISR_ztop=loop+1
+
+   				endif
+			enddo
+	      
+			if(box_cloudy(j,ibox)) then
+			
+				! there is an isccp clouds so itau(j) is defined
+     				fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
+     &          			fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
+     
+			else
+				! MISR CTH resolution is trying to fill in a
+				! broken cloud scene where there is no condensate.
+				! The MISR CTH-1D-OD product will only put in a cloud
+				! if the MISR cloud mask indicates cloud.
+				! therefore we will not include this column in the histogram
+				! in reality aerosoal and 3D effects or bright surfaces
+				! could fool the MISR cloud mask
+
+				! the alternative is to count as very thin cloud ??
+!				fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
+!     &          			fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
+			endif
+
+
+			MISR_mean_ztop(j)=MISR_mean_ztop(j)+
+     &					     box_MISR_ztop(j,ibox)*boxarea   		
+
+			MISR_cldarea(j)=MISR_cldarea(j) + boxarea 
+ 
+	      endif
+		
+	   endif ! is sunlight ?
+	   
+	enddo ! ibox - loop over subcolumns          
+      
+	if( MISR_cldarea(j) .gt. 0.) then
+	  	MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
+	endif
+
+      enddo  ! loop over grid points
+
+      return
+      end 
Index: LMDZ5/branches/testing/libf/phylmd/cosp/array_lib.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/array_lib.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/array_lib.F90	(revision 2298)
@@ -0,0 +1,165 @@
+! 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: LMDZ5/branches/testing/libf/phylmd/cosp/atmos_lib.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/atmos_lib.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/atmos_lib.F90	(revision 2298)
@@ -0,0 +1,135 @@
+! 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: LMDZ5/branches/testing/libf/phylmd/cosp/congvec.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/congvec.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/congvec.h	(revision 2298)
@@ -0,0 +1,54 @@
+
+! *****************************COPYRIGHT****************************
+! (c) British Crown Copyright 2009, 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.  
+! 
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+
+      do irand = 1, npoints
+          ! Marsaglia CONG algorithm
+          seed(irand)=69069*seed(irand)+1234567
+          ! mod 32 bit overflow
+          seed(irand)=mod(seed(irand),2**30)   
+          ran(irand)=seed(irand)*0.931322574615479E-09
+      enddo
+
+      ! convert to range 0-1 (32 bit only)
+      overflow_32=i2_16*i2_16
+      if ( overflow_32 .le. huge32 ) then
+          do irand = 1, npoints
+              ran(irand)=ran(irand)+1
+              ran(irand)=(ran(irand))-int(ran(irand))
+          enddo
+      endif
+
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp.F90	(revision 2298)
@@ -0,0 +1,512 @@
+! (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.
+
+!!#include "cosp_defs.h"
+MODULE MOD_COSP
+  USE MOD_COSP_TYPES
+  USE MOD_COSP_SIMULATOR
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  IMPLICIT NONE
+
+CONTAINS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE COSP ---------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+
+  ! Arguments
+  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
+  integer,intent(in) :: Ncolumns
+  type(cosp_config),intent(in) :: cfg   ! Configuration options
+  type(cosp_vgrid),intent(in) :: vgrid   ! Information on vertical grid of stats
+  type(cosp_gridbox),intent(inout) :: gbx
+  type(cosp_subgrid),intent(inout) :: sgx   ! Subgrid info
+  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
+  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
+  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
+  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
+  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
+
+  ! Local variables 
+  integer :: Npoints   ! Number of gridpoints
+  integer :: Nlevels   ! Number of levels
+  integer :: Nhydro    ! Number of hydrometeors
+  integer :: Niter     ! Number of calls to cosp_simulator
+  integer :: i_first,i_last ! First and last gridbox to be processed in each iteration
+  integer :: i,j,k,Ni
+  integer,dimension(2) :: ix,iy
+  logical :: reff_zero
+  real :: minv,maxv
+  real :: maxp,minp
+  integer,dimension(:),save,  allocatable :: & ! Dimensions nPoints
+                  seed    !  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 same 
+                          !  seed value every time may introduce some statistical bias in the results, 
+                          !  particularly for low values of NCOL.
+!$OMP THREADPRIVATE(seed)
+  real,dimension(:),allocatable :: rseed    !  It is recommended that the seed is set to a different value for each model
+  ! Types used in one iteration
+  type(cosp_gridbox) :: gbx_it
+  type(cosp_subgrid) :: sgx_it
+  type(cosp_vgrid)   :: vgrid_it
+  type(cosp_sgradar) :: sgradar_it
+  type(cosp_sglidar) :: sglidar_it
+  type(cosp_isccp)   :: isccp_it
+  type(cosp_misr)    :: misr_it
+  type(cosp_radarstats) :: stradar_it
+  type(cosp_lidarstats) :: stlidar_it
+  
+  logical,save :: first_cosp=.TRUE.
+!$OMP THREADPRIVATE(first_cosp)
+  
+  !++++++++++ Dimensions ++++++++++++
+  Npoints  = gbx%Npoints
+  Nlevels  = gbx%Nlevels
+  Nhydro   = gbx%Nhydro
+
+!++++++++++ Apply sanity checks to inputs ++++++++++
+!  call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0)
+  call cosp_check_input('longitude',gbx%longitude,min_val=-180.0,max_val=180.0)
+  call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0)
+  call cosp_check_input('dlev',gbx%dlev,min_val=0.0)
+  call cosp_check_input('p',gbx%p,min_val=0.0)
+  call cosp_check_input('ph',gbx%ph,min_val=0.0)
+  call cosp_check_input('T',gbx%T,min_val=0.0)
+  call cosp_check_input('q',gbx%q,min_val=0.0)
+  call cosp_check_input('sh',gbx%sh,min_val=0.0)
+  call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0)
+  call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0)
+  call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0)
+  call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0)
+  ! Point information (Npoints)
+  call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0)
+  call cosp_check_input('psfc',gbx%psfc,min_val=0.0)
+  call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0)
+  call cosp_check_input('skt',gbx%skt,min_val=0.0)
+  ! TOTAL and CONV cloud fraction for SCOPS
+  call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0)
+  call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0)
+  ! Precipitation fluxes on model levels
+  call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0)
+  call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0)
+  call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0)
+  call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0)
+  call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0)
+  ! Hydrometeors concentration and distribution parameters
+  call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0)
+  ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
+  call cosp_check_input('Reff',gbx%Reff,min_val=0.0)
+  reff_zero=.true.
+  if (any(gbx%Reff > 1.e-8)) then
+     reff_zero=.false.
+      ! reff_zero == .false.
+      !     and gbx%use_reff == .true.   Reff use in radar and lidar
+      !     and reff_zero    == .false.  Reff use in lidar and set to 0 for radar
+  endif
+!  if ((gbx%use_reff) .and. (reff_zero)) then ! Inconsistent choice. Want to use Reff but not inputs passed
+!        print *, '---------- COSP ERROR ------------'
+!        print *, ''
+!        print *, 'use_reff==.true. but Reff is always zero'
+!        print *, ''
+!        print *, '----------------------------------'
+!        stop
+!  endif
+  if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar
+        gbx%Reff = DEFAULT_LIDAR_REFF
+        print *, '---------- COSP WARNING ------------'
+        print *, ''
+        print *, 'Using default Reff in lidar simulations'
+        print *, ''
+        print *, '----------------------------------'
+  endif
+  
+  ! Aerosols concentration and distribution parameters
+  call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0)
+  ! Checks for CRM mode
+  if (Ncolumns == 1) then
+     if (gbx%use_precipitation_fluxes) then
+        print *, '---------- COSP ERROR ------------'
+        print *, ''
+        print *, 'Use of precipitation fluxes not supported in CRM mode (Ncolumns=1)'
+        print *, ''
+        print *, '----------------------------------'
+        stop
+     endif
+     if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then
+        print *, '---------- COSP ERROR ------------'
+        print *, ''
+        print *, ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1), '
+        print *, ' the optical depth (emmisivity) of all clouds must be '
+        print *, ' passed through dtau_s (dem_s)'
+        print *, ''
+        print *, '----------------------------------'
+        stop
+     endif
+  endif
+
+  if (first_cosp) then   
+   ! We base the seed in the decimal part of the surface pressure.
+     allocate(seed(Npoints))
+
+     allocate(rseed(klon_glo))
+     CALL gather(gbx%psfc,rseed)
+     call bcast(rseed)
+!   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1   
+      ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to 
+      ! randomize for each call to COSP even when Npoints ==1
+     minp = minval(rseed)
+     maxp = maxval(rseed)
+   
+     if (Npoints .gt. 1) THEN
+       seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1
+     else
+       seed=int(gbx%psfc-minp)
+     endif
+
+     deallocate(rseed)
+     first_cosp=.false.
+   endif
+    
+   if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints
+        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+   else ! Several iterations to save memory
+        Niter = gbx%Npoints/gbx%Npoints_it ! Integer division
+        if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1
+        do i=1,Niter
+            i_first = (i-1)*gbx%Npoints_it + 1
+            i_last  = i_first + gbx%Npoints_it - 1
+            i_last  = min(i_last,gbx%Npoints)
+            Ni = i_last - i_first + 1
+            if (i == 1) then
+                ! Allocate types for all but last iteration
+                call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
+                                            gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
+                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
+                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
+                                            gbx%use_precipitation_fluxes,gbx%use_reff, &
+                                            gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, &
+                                            gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), &
+                                            gbx%co2,gbx%ch4,gbx%n2o,gbx%co, &
+                                            gbx_it)
+                call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it)
+                call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it)
+                call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it)
+                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
+                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
+                call construct_cosp_misr(cfg,Ni,misr_it)
+                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
+                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
+            elseif (i == Niter) then ! last iteration
+                call free_cosp_gridbox(gbx_it,.true.)
+                call free_cosp_subgrid(sgx_it)
+                call free_cosp_vgrid(vgrid_it)
+                call free_cosp_sgradar(sgradar_it)
+                call free_cosp_sglidar(sglidar_it)
+                call free_cosp_isccp(isccp_it)
+                call free_cosp_misr(misr_it)
+                call free_cosp_radarstats(stradar_it)
+                call free_cosp_lidarstats(stlidar_it)
+                ! Allocate types for iterations
+                call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
+                                            gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
+                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
+                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
+                                            gbx%use_precipitation_fluxes,gbx%use_reff, &
+                                            gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, &
+                                            gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), &
+                                            gbx%co2,gbx%ch4,gbx%n2o,gbx%co, &
+                                            gbx_it)
+                ! --- Copy arrays without Npoints as dimension ---
+                gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro
+                gbx_it%dist_type_aero   = gbx_it%dist_type_aero
+                call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it)
+                call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it)
+                call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it)
+                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
+                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
+                call construct_cosp_misr(cfg,Ni,misr_it)
+                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
+                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
+            endif
+            ! --- Copy sections of arrays with Npoints as dimension ---
+            ix=(/i_first,i_last/)
+            iy=(/1,Ni/)
+            call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it)
+              ! These serve as initialisation of *_it types
+            call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it)
+            if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it)
+            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it)
+            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it)
+            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr,misr_it)
+            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it)
+            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it)
+            print *,'---------ix: ',ix
+            call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
+                           sglidar_it,isccp_it,misr_it,stradar_it,stlidar_it)
+            
+            ! --- Copy results to output structures ---
+!             call cosp_gridbox_cphp(gbx_it,gbx)
+            ix=(/1,Ni/)
+            iy=(/i_first,i_last/)
+            call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx)
+            if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar)
+            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar)
+            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp)
+            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr_it,misr)
+            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar)
+            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar)
+        enddo
+        ! Deallocate types
+        call free_cosp_gridbox(gbx_it,.true.)
+        call free_cosp_subgrid(sgx_it)
+        call free_cosp_vgrid(vgrid_it)
+        call free_cosp_sgradar(sgradar_it)
+        call free_cosp_sglidar(sglidar_it)
+        call free_cosp_isccp(isccp_it)
+        call free_cosp_misr(misr_it)
+        call free_cosp_radarstats(stradar_it)
+        call free_cosp_lidarstats(stlidar_it)
+   endif
+
+    
+END SUBROUTINE COSP
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE COSP_ITER ----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+
+  ! Arguments
+  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
+  integer,dimension(:),intent(in) :: seed
+  type(cosp_config),intent(in) :: cfg   ! Configuration options
+  type(cosp_vgrid),intent(in) :: vgrid   ! Information on vertical grid of stats
+  type(cosp_gridbox),intent(inout) :: gbx
+  type(cosp_subgrid),intent(inout) :: sgx   ! Subgrid info
+  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
+  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
+  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
+  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
+  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
+
+  ! Local variables 
+  integer :: Npoints   ! Number of gridpoints
+  integer :: Ncolumns  ! Number of subcolumns
+  integer :: Nlevels   ! Number of levels
+  integer :: Nhydro    ! Number of hydrometeors
+  integer :: Niter     ! Number of calls to cosp_simulator
+  integer :: i,j,k
+  integer :: I_HYDRO
+  real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out
+  integer,parameter :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
+  
+  real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, &
+                     tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud.
+                               ! Levels are from TOA to SURFACE. (nPoints, nLev)
+  real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level
+                                                                     ! Levels are from SURFACE to TOA
+  real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric dens
+  type(cosp_sghydro) :: sghydro   ! Subgrid info for hydrometeors en each iteration
+
+  
+  !++++++++++ Dimensions ++++++++++++
+  Npoints  = gbx%Npoints
+  Ncolumns = gbx%Ncolumns
+  Nlevels  = gbx%Nlevels
+  Nhydro   = gbx%Nhydro
+    
+   
+  !++++++++++ Climate/NWP mode ++++++++++  
+  if (Ncolumns > 1) then
+        !++++++++++ Subgrid sampling ++++++++++
+        ! Allocate arrays before calling SCOPS
+        allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels))
+        allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), &
+                ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels))
+        ! Initialize to zero
+        frac_ls=0.0
+        prec_ls=0.0
+        frac_cv=0.0
+        prec_cv=0.0
+        ! Cloud fractions for SCOPS from TOA to SFC
+        tca_scops = gbx%tca(:,Nlevels:1:-1)
+        cca_scops = gbx%cca(:,Nlevels:1:-1)
+        
+        ! Call to SCOPS
+        ! strat and conv arrays are passed with levels from TOA to SURFACE.
+        call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug)
+        
+        ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops
+        if(gbx%use_precipitation_fluxes) then
+            ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels)
+            cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels)
+        else
+            ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ &
+                                      gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ &
+                                      gbx%mr_hydro(:,1:Nlevels,I_LSGRPL)
+            cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ &
+                                      gbx%mr_hydro(:,1:Nlevels,I_CVSNOW)
+        endif
+        
+        call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac)
+        
+        ! Precipitation fraction
+        do j=1,Npoints,1
+        do k=1,Nlevels,1
+            do i=1,Ncolumns,1
+                if (sgx%frac_out (j,i,Nlevels+1-k) == I_LSC) frac_ls(j,k)=frac_ls(j,k)+1.
+                if (sgx%frac_out (j,i,Nlevels+1-k) == I_CVC) frac_cv(j,k)=frac_cv(j,k)+1.
+                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1.
+                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1.
+                if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then
+                    prec_cv(j,k)=prec_cv(j,k)+1.
+                    prec_ls(j,k)=prec_ls(j,k)+1.
+                endif
+            enddo  !i
+            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  !k
+        enddo  !j
+        
+         ! Levels from SURFACE to TOA.
+        if (Npoints*Ncolumns*Nlevels < 10000) then
+            sgx%frac_out(1:Npoints,:,1:Nlevels)  = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
+            sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1)
+        else
+            ! This is done within a loop (unvectorized) over nPoints to save memory
+            do j=1,Npoints
+                sgx%frac_out(j,:,1:Nlevels)  = sgx%frac_out(j,:,Nlevels:1:-1)
+                sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1)
+            enddo
+        endif
+       
+       ! Deallocate arrays that will no longer be used
+        deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate)
+         
+        ! Populate the subgrid arrays
+        call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
+        do k=1,Ncolumns
+            !--------- Mixing ratios for clouds and Reff for Clouds and precip -------
+            column_frac_out => sgx%frac_out(:,k,:)
+            where (column_frac_out == I_LSC)     !+++++++++++ LS clouds ++++++++
+                sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ)
+                sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE)
+                
+                sghydro%Reff(:,k,:,I_LSCLIQ)     = gbx%Reff(:,:,I_LSCLIQ)
+                sghydro%Reff(:,k,:,I_LSCICE)     = gbx%Reff(:,:,I_LSCICE)
+                sghydro%Reff(:,k,:,I_LSRAIN)     = gbx%Reff(:,:,I_LSRAIN)
+                sghydro%Reff(:,k,:,I_LSSNOW)     = gbx%Reff(:,:,I_LSSNOW)
+                sghydro%Reff(:,k,:,I_LSGRPL)     = gbx%Reff(:,:,I_LSGRPL)
+            elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++
+                sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) 
+                sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) 
+                
+                sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ) 
+                sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE) 
+                sghydro%Reff(:,k,:,I_CVRAIN)     = gbx%Reff(:,:,I_CVRAIN) 
+                sghydro%Reff(:,k,:,I_CVSNOW)     = gbx%Reff(:,:,I_CVSNOW) 
+            end where 
+            !--------- Precip -------
+            if (.not. gbx%use_precipitation_fluxes) then
+                where (column_frac_out == I_LSC)  !+++++++++++ LS Precipitation ++++++++
+                    sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN)
+                    sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW)
+                    sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL)
+                elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++
+                    sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) 
+                    sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) 
+                end where 
+            endif
+        enddo
+        ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values
+        do k=1,Nlevels
+            do j=1,Npoints
+                !--------- Clouds -------
+                if (frac_ls(j,k) .ne. 0.) then
+                    sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k)
+                    sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k)
+                endif
+                if (frac_cv(j,k) .ne. 0.) then
+                    sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k)
+                    sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k)
+                endif
+                !--------- Precip -------
+                if (gbx%use_precipitation_fluxes) then
+                    if (prec_ls(j,k) .ne. 0.) then
+                        gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k)
+                        gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k)
+                        gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k)
+                    endif
+                    if (prec_cv(j,k) .ne. 0.) then
+                        gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k)
+                        gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k)
+                    endif
+                else
+                    if (prec_ls(j,k) .ne. 0.) then
+                        sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k)
+                        sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k)
+                        sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k)
+                    endif
+                    if (prec_cv(j,k) .ne. 0.) then
+                        sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k)
+                        sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k)
+                    endif
+                endif  
+            enddo !k
+        enddo !j
+        deallocate(frac_ls,prec_ls,frac_cv,prec_cv)
+        
+        if (gbx%use_precipitation_fluxes) then
+            ! convert precipitation flux into mixing ratio
+            call pf_to_mr(Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, &
+                        gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, &
+                        sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), &
+                        sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW))
+       endif
+   !++++++++++ CRM mode ++++++++++
+   else
+      sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro
+      sghydro%Reff(:,1,:,:) = gbx%Reff
+      !--------- Clouds -------
+      where ((gbx%dtau_s > 0.0))
+             sgx%frac_out(:,1,:) = 1  ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels)
+      endwhere
+   endif ! Ncolumns > 1
+  
+   
+   !++++++++++ Simulator ++++++++++
+    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
+
+    ! Deallocate subgrid arrays
+    call free_cosp_sghydro(sghydro)
+END SUBROUTINE COSP_ITER
+
+END MODULE MOD_COSP
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_constants.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_constants.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_constants.F90	(revision 2298)
@@ -0,0 +1,131 @@
+! (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.
+
+!
+! 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
+!
+! 
+MODULE MOD_COSP_CONSTANTS
+    use netcdf, only: nf90_fill_real
+    IMPLICIT NONE
+    
+    ! Indices to address arrays of LS and CONV hydrometeors
+    integer,parameter :: I_LSCLIQ = 1
+    integer,parameter :: I_LSCICE = 2
+    integer,parameter :: I_LSRAIN = 3
+    integer,parameter :: I_LSSNOW = 4
+    integer,parameter :: I_CVCLIQ = 5
+    integer,parameter :: I_CVCICE = 6
+    integer,parameter :: I_CVRAIN = 7
+    integer,parameter :: I_CVSNOW = 8
+    integer,parameter :: I_LSGRPL = 9
+    
+    ! Missing value
+!!    real,parameter :: R_UNDEF = -1.0E30
+!     real,parameter :: R_UNDEF = 9.96921e+36
+      real,parameter :: R_UNDEF = nf90_fill_real
+
+    ! Number of possible output variables
+    integer,parameter :: N_OUT_LIST = 27
+    ! Value for forward model result from a level that is under the ground
+    real,parameter :: R_GROUND = -1.0E20
+
+    ! Stratiform and convective clouds in frac_out
+    integer, parameter :: I_LSC = 1, & ! Large-scale clouds
+                          I_CVC = 2    ! Convective clouds
+    
+    !--- Radar constants
+    ! CFAD constants
+    integer,parameter :: DBZE_BINS     =   15   ! Number of dBZe bins in histogram (cfad)
+    real,parameter    :: DBZE_MIN      = -100.0 ! Minimum value for radar reflectivity
+    real,parameter    :: DBZE_MAX      =   80.0 ! Maximum value for radar reflectivity
+    real,parameter    :: CFAD_ZE_MIN   =  -50.0 ! Lower value of the first CFAD Ze bin
+    real,parameter    :: CFAD_ZE_WIDTH =    5.0 ! Bin width (dBZe)
+
+   
+    !--- Lidar constants
+    ! CFAD constants
+    integer,parameter :: SR_BINS       =   15
+    integer,parameter :: DPOL_BINS     =   6
+    real,parameter    :: LIDAR_UNDEF   =   999.999
+    ! Other constants
+    integer,parameter :: LIDAR_NCAT    =   4
+    integer,parameter :: PARASOL_NREFL =   5 ! parasol
+    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 6.0, 80.0/)
+!    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/1.0, 2.0, 3.0, 4.0, 5.0/)
+    real,parameter    :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius
+    
+    !--- MISR constants
+    integer,parameter :: MISR_N_CTH = 16
+
+    !--- RTTOV constants
+    integer,parameter :: RTTOV_MAX_CHANNELS = 20
+    
+    ! ISCCP tau-Pc axes
+    real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 50000.0/)
+    real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, &
+                                                      9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/))
+   
+!     real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./)
+!     real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, &
+!                                44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/))
+   
+    real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)
+    real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = 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,7/))
+    
+    real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = (/ 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,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 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,MISR_N_CTH/))
+            
+    !  Table hclass for quickbeam
+    integer,parameter :: N_HYDRO = 9
+    real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), &
+            HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO)
+    real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
+            HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
+    data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/
+    data HCLASS_COL/1,2,3,4,5,6,7,8,9/
+    data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/
+    data HCLASS_CP/0,0,1,1,0,0,1,1,1/
+    data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/
+    data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/
+    data HCLASS_APM/524,110.8,524,-1,524,110.8,524,-1,-1/
+    data HCLASS_BPM/3,2.91,3,-1,3,2.91,3,-1,-1/
+    data HCLASS_RHO/-1,-1,-1,100,-1,-1,-1,100,400/
+    data HCLASS_P1/-1,-1,8000000.,3000000.,-1,-1,8000000.,3000000.,4000000./
+    data HCLASS_P2/6,40,-1,-1,6,40,-1,-1,-1/
+    data HCLASS_P3/0.3,2,-1,-1,0.3,2,-1,-1,-1/
+
+    
+    
+END MODULE MOD_COSP_CONSTANTS
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_isccp_simulator.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_isccp_simulator.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_isccp_simulator.F90	(revision 2298)
@@ -0,0 +1,96 @@
+! (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_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 :: i,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)
+     
+  ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR
+!  y%boxptop = y%boxptop*100.0
+  
+  ! 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: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_lidar.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_lidar.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_lidar.F90	(revision 2298)
@@ -0,0 +1,87 @@
+! (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.
+
+!
+! 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)
+!
+! 
+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 :: frac_out(sgx%Npoints, sgx%Nlevels)
+  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, PARASOL_NREFL)  :: refle
+  
+  
+  presf(:,1:sgx%Nlevels) = gbx%ph
+  presf(:,sgx%Nlevels + 1) = 0.0
+!   presf(:,sgx%Nlevels + 1) = gbx%p(:,sgx%Nlevels) - (presf(:,sgx%Nlevels) - gbx%p(:,sgx%Nlevels)) 
+  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)
+      frac_out(:,:) = sgx%frac_out(:,i,:)    
+      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) &
+                 , frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot  &
+                 , refle ) ! reflectance
+      
+      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: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_misr_simulator.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_misr_simulator.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_misr_simulator.F90	(revision 2298)
@@ -0,0 +1,80 @@
+! (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.
+
+!
+! 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 :: i,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
+  real :: phy_t0p1_mean_ztop              ! mean cloud top height(m) of 0.1 tau treshold
+  real :: fq_phy_t0p1_TAU_v_CTH(7,16)      
+     
+  	
+  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, &
+                     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: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_mod.F90	(revision 2298)
@@ -0,0 +1,239 @@
+! A.Idelkadi sept 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Module pour declarer et initialiser les parametres de controle des fichiers de sorties et des champs a sortir
+!! La routine cosp_output_open (appelee 1 seule fois dans phy_cosp.F90) permet :
+!! de creer les fichiers avec leurs grilles horizontales et verticales
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  MODULE cosp_output_mod
+
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+
+! cosp_output_mod
+      INTEGER, PRIVATE             :: i
+!!!!!!! Controle des fichier de sorties Cosp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      LOGICAL, DIMENSION(3), SAVE  :: cosp_outfilekeys
+      INTEGER, DIMENSION(3), SAVE  :: cosp_nidfiles
+!$OMP THREADPRIVATE(cosp_outfilekeys, cosp_nidfiles)
+      INTEGER, DIMENSION(3), SAVE  :: nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp
+      REAL, DIMENSION(3), SAVE                :: zoutm_cosp
+!$OMP THREADPRIVATE(nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp, zoutm_cosp)
+      REAL, SAVE                   :: zdtimemoy_cosp
+!$OMP THREADPRIVATE(zdtimemoy_cosp) 
+      CHARACTER(LEN=20), DIMENSION(3), SAVE  :: cosp_outfiletypes
+      CHARACTER(LEN=20), DIMENSION(3), SAVE  :: cosp_outfilenames
+      REAL, DIMENSION(3), SAVE               :: cosp_ecritfiles 
+!$OMP THREADPRIVATE(cosp_outfiletypes, cosp_outfilenames, cosp_ecritfiles)
+
+!!!!  Controle des variables a sortir dans les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  TYPE ctrl_outcosp
+     LOGICAL,DIMENSION(3)                 :: cles             !!! Sortir ou non le champs
+     CHARACTER(len=20)                    :: name       
+     CHARACTER(len=150)                   :: description      !!! Nom
+     CHARACTER(len=20)                    :: unit             !!! Unite 
+     CHARACTER(len=20),DIMENSION(3)  :: cosp_typeecrit        !!! Operation (ave, inst, ...)
+  END TYPE ctrl_outcosp
+! CALIPSO vars
+  TYPE(ctrl_outcosp), SAVE :: o_cllcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cllcalipso", "Lidar Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /))                                   
+  TYPE(ctrl_outcosp), SAVE :: o_clmcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmcalipso", "Lidar Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clhcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clhcalipso", "Lidar Hight-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cltcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cltcalipso", "Lidar Total Cloud Fraction", "1", (/ ('', i=1, 3) /)) 
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipso", "Lidar Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cfad_lidarsr532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+         "cfad_lidarsr532", "Lidar Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /))   
+  TYPE(ctrl_outcosp), SAVE :: o_parasol_refl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "parasol_refl", "PARASOL-like mono-directional reflectance","1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_parasol_crefl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &              
+         "parasol_crefl", "PARASOL-like mono-directional reflectance (integral)","1", (/ ('', i=1, 3) /))                  
+  TYPE(ctrl_outcosp), SAVE :: o_Ncrefl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "Ncrefl", "Nb PARASOL-like mono-directional reflectance (integral)","1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_atb532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+         "atb532", "Lidar Attenuated Total Backscatter (532 nm)","1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_beta_mol532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+         "beta_mol532", "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /))
+! ISCCP vars
+  TYPE(ctrl_outcosp), SAVE :: o_sunlit = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "sunlit", "1 for day points, 0 for nightime","1",(/ ('', i=1, 3) /))                   
+  TYPE(ctrl_outcosp), SAVE :: o_clisccp2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clisccp2", "Cloud Fraction as Calculated by the ISCCP Simulator","1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_boxtauisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+         "boxtauisccp", "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_boxptopisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+         "boxptopisccp", "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tclisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+          "tclisccp", "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", (/ ('', i=1, 3) /)) 
+  TYPE(ctrl_outcosp), SAVE :: o_ctpisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+          "ctpisccp", "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tauisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+          "tauisccp", "Optical Depth as Calculated by the ISCCP Simulator", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_albisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+          "albisccp", "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_meantbisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+          "meantbisccp", " Mean all-sky 10.5 micron brightness temperature as calculated &
+           by the ISCCP Simulator","K", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_meantbclrisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
+          "meantbclrisccp", "Mean clear-sky 10.5 micron brightness temperature as calculated &
+           by the ISCCP Simulator","K", (/ ('', i=1, 3) /))
+
+   LOGICAL, SAVE :: cosp_varsdefined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!! Ouverture des fichier et definition des  axes!!!!!!!!
+  !! histbeg, histvert
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+
+  SUBROUTINE 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, vgrid)
+
+
+  USE iophy
+  USE ioipsl
+  USE phys_cal_mod
+
+#ifdef CPP_XIOS
+    ! ug Pour les sorties XIOS
+    USE wxios
+#endif
+
+  IMPLICIT NONE
+
+!!! Variables d'entree
+  integer                  :: Nlevlmdz, Ncolumns      ! Number of levels
+  real,dimension(Nlevlmdz) :: presnivs
+  real                     :: dtime, freq_cosp, ecrit_day, ecrit_hf, ecrit_mth 
+  logical                  :: ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, use_vgrid, ok_all_xml                    
+  type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
+
+!!! Variables locales
+  integer                  :: idayref, iff, ii
+  real                     :: zjulian,zjulian_start
+  real,dimension(Ncolumns) :: column_ax
+  CHARACTER(LEN=20), DIMENSION(3)  :: chfreq = (/ '1day', '1d', '3h' /)            
+
+!!! Variables d'entree
+  include "temps.h"
+  INCLUDE 'iniprint.h'
+
+#ifdef CPP_XIOS
+    ! ug Variables utilisées pour récupérer le calendrier pour xios
+    INTEGER :: x_an, x_mois, x_jour
+    REAL :: x_heure
+    INTEGER :: ini_an, ini_mois, ini_jour
+    REAL :: ini_heure
+#endif
+
+    WRITE(lunout,*) 'Debut cosp_output_mod.F90'
+    print*,'cosp_varsdefined',cosp_varsdefined
+    ! Initialisations (Valeurs par defaut)
+
+    do ii=1,Ncolumns
+      column_ax(ii) = real(ii)
+    enddo
+
+
+    cosp_outfilenames(1) = 'histmthCOSP'
+    cosp_outfilenames(2) = 'histdayCOSP'
+    cosp_outfilenames(3) = 'histhfCOSP'
+
+    cosp_outfiletypes(1) = 'ave(X)'
+    cosp_outfiletypes(2) = 'ave(X)'
+    cosp_outfiletypes(3) = 'ave(X)'
+
+    cosp_outfilekeys(1) = ok_mensuelCOSP
+    cosp_outfilekeys(2) = ok_journeCOSP
+    cosp_outfilekeys(3) = ok_hfCOSP
+
+    cosp_ecritfiles(1) = mth_len*86400.
+    cosp_ecritfiles(2) = 1.*86400.
+    cosp_ecritfiles(3) = 0.125*86400.
+
+! Lecture des parametres dans output.def ou config.def
+
+    CALL getin('cosp_outfilenames',cosp_outfilenames)
+    CALL getin('cosp_outfilekeys',cosp_outfilekeys)
+    CALL getin('cosp_ecritfiles',cosp_ecritfiles)
+    CALL getin('cosp_outfiletypes',cosp_outfiletypes)
+
+    WRITE(lunout,*)'cosp_outfilenames=',cosp_outfilenames
+    WRITE(lunout,*)'cosp_outfilekeys=',cosp_outfilekeys
+    WRITE(lunout,*)'cosp_ecritfiles=',cosp_ecritfiles
+    WRITE(lunout,*)'cosp_outfiletypes=',cosp_outfiletypes
+    
+    idayref = day_ref
+    CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+    CALL ymds2ju(annee_ref, 1, day_ini, start_time, zjulian_start)
+
+#ifdef CPP_XIOS
+    ! ug R\'eglage du calendrier xios
+    !Temps julian => an, mois, jour, heure
+!    CALL ju2ymds(zjulian, x_an, x_mois, x_jour, x_heure)
+!    CALL ju2ymds(zjulian_start, ini_an, ini_mois, ini_jour, ini_heure)
+!    CALL wxios_set_cal(dtime, calend, x_an, x_mois, x_jour, x_heure, ini_an, &
+!                       ini_mois, ini_jour, ini_heure )
+       ! ug dï¿½claration des axes verticaux de chaque fichier:
+!    if (use_vgrid) then
+        CALL wxios_add_vaxis("height", vgrid%Nlvgrid, vgrid%z)
+!    else
+!         WRITE(lunout,*) 'wxios_add_vaxis "presnivs", vgrid%Nlvgrid ',vgrid%Nlvgrid
+!        CALL wxios_add_vaxis("presnivs", vgrid%Nlvgrid, presnivs)
+!    endif
+    WRITE(lunout,*) 'wxios_add_vaxis height_mlev, Nlevlmdz ',Nlevlmdz
+    CALL wxios_add_vaxis("height_mlev", Nlevlmdz, vgrid%mz)
+    WRITE(lunout,*) 'wxios_add_vaxis sza, PARASOL_NREFL ',PARASOL_NREFL
+    CALL wxios_add_vaxis("sza", PARASOL_NREFL, PARASOL_SZA)
+    WRITE(lunout,*) 'wxios_add_vaxis pressure2 ',7
+    CALL wxios_add_vaxis("pressure2", 7, ISCCP_PC)
+    WRITE(lunout,*) 'wxios_add_vaxis column ',Ncolumns
+    CALL wxios_add_vaxis("column", Ncolumns, column_ax)
+#endif
+   
+    zdtimemoy_cosp = freq_COSP         ! Frequence ou l on moyenne
+
+    DO iff=1,3
+       zoutm_cosp(iff) = cosp_ecritfiles(iff) ! Frequence ou l on ecrit en seconde
+
+       IF (cosp_outfilekeys(iff)) THEN
+           CALL histbeg_phy_all(cosp_outfilenames(iff),itau_phy,zjulian,&
+             dtime,nhoricosp(iff),cosp_nidfiles(iff))
+           print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', &
+                    nhoricosp(iff),cosp_nidfiles(iff)
+
+#ifdef CPP_XIOS
+        IF (.not. ok_all_xml) then
+         WRITE(lunout,*) 'wxios_add_file ',cosp_outfilenames(iff)
+         CALL wxios_add_file(cosp_outfilenames(iff),chfreq(iff),10)
+        ENDIF
+#endif
+
+#ifndef CPP_IOIPSL_NO_OUTPUT 
+! Definition de l'axe vertical
+       if (use_vgrid) then
+! Axe vertical Cosp 40 niveaux (en m)
+      CALL histvert(cosp_nidfiles(iff),"height","height","m",vgrid%Nlvgrid,vgrid%z,nvert(iff))
+       else
+! Axe vertical modele LMDZ presnivs
+      CALL histvert(cosp_nidfiles(iff),"presnivs","Vertical levels","Pa",vgrid%Nlvgrid,presnivs,nvert(iff),"down")
+       endif
+! Axe vertical niveaux modele (en m)
+      CALL histvert(cosp_nidfiles(iff),"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertmcosp(iff))
+
+      CALL histvert(cosp_nidfiles(iff),"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp(iff))
+
+      CALL histvert(cosp_nidfiles(iff),"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp(iff),"down")
+
+      CALL histvert(cosp_nidfiles(iff),"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol(iff))
+#endif
+
+      ENDIF
+  ENDDO
+
+    end SUBROUTINE cosp_output_open
+
+ END MODULE cosp_output_mod
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_write_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_write_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_write_mod.F90	(revision 2298)
@@ -0,0 +1,629 @@
+!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   MODULE cosp_output_write_mod
+  
+   USE cosp_output_mod
+  
+   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 cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
+                               cfg, gbx, vgrid, sglidar, stlidar, isccp)
+
+    USE ioipsl
+    USE control_mod
+
+#ifdef CPP_XIOS
+    USE wxios, only: wxios_closedef
+    USE xios, only: xios_update_calendar
+#endif
+
+!!! Variables d'entree
+  integer               :: itap, Nlevlmdz, Ncolumns, Npoints
+  real                  :: freq_COSP, dtime
+  type(cosp_config)     :: cfg     ! Control outputs
+  type(cosp_gridbox)    :: gbx     ! Gridbox information. Input for COSP
+  type(cosp_sglidar)    :: sglidar ! Output from lidar simulator
+  type(cosp_isccp)      :: isccp   ! Output from ISCCP simulator
+  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
+  type(cosp_vgrid)      :: vgrid   ! Information on vertical grid of stats
+
+!!! Variables locales
+  integer               :: icl
+  logical               :: ok_sync
+  integer               :: itau_wcosp
+  real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref
+
+  include "temps.h"
+  include "iniprint.h"
+
+  Nlevout = vgrid%Nlvgrid
+  Ncolout = Ncolumns
+
+! A refaire
+       itau_wcosp = itau_phy + itap + start_time * day_step / iphysiq
+        if (prt_level >= 10) then
+             WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step, iphysiq =', & 
+                             itau_wcosp, itap, start_time, day_step, iphysiq
+        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.
+    
+!DO iinit=1, iinitend
+! AI sept 2014 cette boucle supprimee
+! On n'ecrit pas quand itap=1 (cosp)
+
+   if (prt_level >= 10) then
+         WRITE(lunout,*)'DO iinit=1, iinitend ',iinitend
+   endif
+
+!#ifdef CPP_XIOS
+! !$OMP MASTER
+!IF (cosp_varsdefined) THEN
+!   if (prt_level >= 10) then
+!         WRITE(lunout,*)'Apell xios_update_calendar cosp_varsdefined iinitend ', &
+!                         cosp_varsdefined,iinitend
+!   endif 
+!    CALL xios_update_calendar(itau_wcosp)
+!ENDIF
+!  !$OMP END MASTER
+!  !$OMP BARRIER
+!#endif
+
+ if (cfg%Llidar_sim) then
+! Pb des valeurs indefinies, on les met a 0
+! A refaire proprement
+  do k = 1,Nlevout
+     do ip = 1,Npoints
+     if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then
+      stlidar%lidarcld(ip,k)=0.
+     endif
+     enddo
+
+     do ii= 1,SR_BINS
+      do ip = 1,Npoints
+       if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then
+        stlidar%cfad_sr(ip,ii,k)=0.
+       endif
+      enddo
+     enddo
+   enddo
+
+  do ip = 1,Npoints
+   do k = 1,Nlevlmdz
+     if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then
+      sglidar%beta_mol(ip,k)=0.
+     endif
+
+     do ii= 1,Ncolumns
+       if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then
+        sglidar%beta_tot(ip,ii,k)=0.
+       endif
+     enddo
+
+    enddo    !k = 1,Nlevlmdz
+   enddo     !ip = 1,Npoints
+
+   do k = 1,LIDAR_NCAT
+    do ip = 1,Npoints
+     if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then
+      stlidar%cldlayer(ip,k)=0.
+     endif
+    enddo
+   enddo
+
+   print*,'Appel histwrite2d_cosp'
+   CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1))
+   CALL histwrite2d_cosp(o_clhcalipso,stlidar%cldlayer(:,3))
+   CALL histwrite2d_cosp(o_clmcalipso,stlidar%cldlayer(:,2)) 
+   CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4))
+   CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert)
+
+   do icl=1,SR_BINS
+      CALL histwrite3d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr(:,icl,:),nvert,icl)
+   enddo
+
+   CALL histwrite3d_cosp(o_parasol_refl,stlidar%parasolrefl,nvertp)
+
+   do k=1,PARASOL_NREFL
+    do ip=1, Npoints
+     if (stlidar%cldlayer(ip,4).gt.0.01) then
+       parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)))/ &
+                            stlidar%cldlayer(ip,4)
+        Ncref(ip,k) = 1.
+     else
+        parasolcrefl(ip,k)=0.
+        Ncref(ip,k) = 0.
+     endif
+    enddo
+   enddo
+   CALL histwrite3d_cosp(o_Ncrefl,Ncref,nvertp)
+   CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp)
+
+   do icl=1,Ncolumns 
+      CALL histwrite3d_cosp(o_atb532,sglidar%beta_tot(:,icl,:),nvertmcosp,icl)
+   enddo
+   CALL histwrite3d_cosp(o_beta_mol532,sglidar%beta_mol,nvertmcosp) 
+ endif !Lidar
+
+ if (cfg%Lisccp_sim) then
+
+! Traitement des valeurs indefinies
+   do ip = 1,Npoints
+    if(isccp%totalcldarea(ip).eq.-1.E+30)then
+      isccp%totalcldarea(ip)=0.
+    endif
+    if(isccp%meanptop(ip).eq.-1.E+30)then
+      isccp%meanptop(ip)=0.
+    endif
+    if(isccp%meantaucld(ip).eq.-1.E+30)then
+      isccp%meantaucld(ip)=0.
+    endif
+    if(isccp%meanalbedocld(ip).eq.-1.E+30)then
+      isccp%meanalbedocld(ip)=0.
+    endif
+    if(isccp%meantb(ip).eq.-1.E+30)then
+      isccp%meantb(ip)=0.
+    endif
+    if(isccp%meantbclr(ip).eq.-1.E+30)then
+      isccp%meantbclr(ip)=0.
+    endif
+
+    do k=1,7
+     do ii=1,7
+     if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then
+      isccp%fq_isccp(ip,ii,k)=0.
+     endif
+     enddo
+    enddo
+
+    do ii=1,Ncolumns
+     if(isccp%boxtau(ip,ii).eq.-1.E+30)then
+       isccp%boxtau(ip,ii)=0.
+     endif
+    enddo
+
+    do ii=1,Ncolumns
+     if(isccp%boxptop(ip,ii).eq.-1.E+30)then
+       isccp%boxptop(ip,ii)=0.
+     endif
+    enddo
+   enddo
+
+   CALL histwrite2d_cosp(o_sunlit,gbx%sunlit)
+   do icl=1,7
+   CALL histwrite3d_cosp(o_clisccp2,isccp%fq_isccp(:,icl,:),nvertisccp,icl) 
+   enddo
+   CALL histwrite3d_cosp(o_boxtauisccp,isccp%boxtau,nvertcol)
+   CALL histwrite3d_cosp(o_boxptopisccp,isccp%boxptop,nvertcol) 
+   CALL histwrite2d_cosp(o_tclisccp,isccp%totalcldarea) 
+   CALL histwrite2d_cosp(o_ctpisccp,isccp%meanptop) 
+   CALL histwrite2d_cosp(o_tauisccp,isccp%meantaucld) 
+   CALL histwrite2d_cosp(o_albisccp,isccp%meanalbedocld) 
+   CALL histwrite2d_cosp(o_meantbisccp,isccp%meantb) 
+   CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr)
+ endif ! Isccp
+
+ IF(.NOT.cosp_varsdefined) THEN
+!$OMP MASTER
+#ifndef CPP_IOIPSL_NO_OUTPUT
+            DO iff=1,3
+                IF (cosp_outfilekeys(iff)) THEN
+                  CALL histend(cosp_nidfiles(iff))
+                ENDIF ! cosp_outfilekeys
+            ENDDO !  iff
+#endif
+! Fermeture dans phys_output_write
+!#ifdef CPP_XIOS
+            !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
+#ifndef CPP_IOIPSL_NO_OUTPUT 
+!$OMP MASTER
+     DO iff=1,3
+         IF (ok_sync .AND. cosp_outfilekeys(iff)) THEN
+             CALL histsync(cosp_nidfiles(iff))
+         ENDIF
+     END DO
+!$OMP END MASTER
+#endif
+    ENDIF  !cosp_varsdefined
+
+    END SUBROUTINE 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
+#ifdef CPP_XIOS
+  USE wxios
+#endif
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "clesphys.h"
+    include "iniprint.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
+
+#ifdef CPP_XIOS
+     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
+#endif
+
+#ifndef CPP_IOIPSL_NO_OUTPUT 
+       IF ( var%cles(iff) ) THEN
+          CALL histdef (cosp_nidfiles(iff), var%name, var%description, var%unit, &
+               iim,jj_nb,nhoricosp(iff), 1,1,1, -99, 32, &
+               typeecrit, zstophym,zoutm_cosp(iff))
+       ENDIF
+#endif
+
+  END SUBROUTINE histdef2d_cosp
+
+ SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols)
+    USE ioipsl
+    USE dimphy
+    use iophy
+    USE mod_phys_lmdz_para
+
+#ifdef CPP_XIOS
+  USE wxios
+#endif
+
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "clesphys.h"
+    include "iniprint.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
+           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
+
+#ifdef CPP_XIOS
+      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
+#endif
+
+#ifndef CPP_IOIPSL_NO_OUTPUT
+       IF ( var%cles(iff) ) THEN
+          CALL histdef (cosp_nidfiles(iff), nom, var%description, var%unit, &
+               iim, jj_nb, nhoricosp(iff), klevs, 1, &
+               klevs, nvertsave, 32, typeecrit, &
+               zstophym, zoutm_cosp(iff))
+       ENDIF
+#endif
+
+  END SUBROUTINE histdef3d_cosp
+
+ SUBROUTINE histwrite2d_cosp(var,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  use iophy
+
+#ifdef CPP_XIOS
+  USE xios, only: xios_send_field
+#endif
+
+  IMPLICIT NONE
+  INCLUDE 'dimensions.h'
+  INCLUDE 'iniprint.h'
+  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(iim,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
+      !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_gcm('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(iim*jj_nb))
+#ifndef CPP_IOIPSL_NO_OUTPUT
+        CALL histwrite(cosp_nidfiles(iff),var%name,itau_iocosp,Field2d,iim*jj_nb,index2d) 
+#endif
+                deallocate(index2d)
+#ifdef CPP_XIOS
+              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
+           ENDIF
+      ENDDO 
+
+#ifdef CPP_XIOS
+      IF (ok_all_xml) THEN
+        if (prt_level >= 10) then
+              WRITE(lunout,*)'xios_send_field variable ',var%name
+        endif
+       CALL xios_send_field(var%name, Field2d)
+      ENDIF
+#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
+
+#ifdef CPP_XIOS
+  USE xios, only: xios_send_field
+#endif
+
+
+  IMPLICIT NONE
+  INCLUDE 'dimensions.h'
+  INCLUDE 'iniprint.h'
+  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(iim,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_gcm('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(iim*jj_nb*nlev))
+#ifndef CPP_IOIPSL_NO_OUTPUT
+    CALL histwrite(cosp_nidfiles(iff),nom,itau_iocosp,Field3d,iim*jj_nb*nlev,index3d) 
+#endif
+
+#ifdef CPP_XIOS
+          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
+#endif
+         deallocate(index3d)
+        ENDIF
+      ENDDO
+#ifdef CPP_XIOS
+    IF (ok_all_xml) THEN
+     CALL xios_send_field(nom, Field3d(:,:,1:nlev))
+     IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
+    ENDIF
+#endif
+
+!$OMP END MASTER   
+  ENDIF ! vars_defined
+  IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom
+  END SUBROUTINE histwrite3d_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
+
+    IMPLICIT NONE
+    include 'iniprint.h'
+
+   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 cosp_output_write_mod
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_radar.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_radar.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_radar.F90	(revision 2298)
@@ -0,0 +1,212 @@
+! (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 radar_simulator_types
+  use array_lib
+  use atmos_lib
+  use format_input
+  IMPLICIT NONE
+  
+  INTERFACE
+    subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
+        nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_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_out)
+  
+        use m_mrgrnk 
+        use array_lib
+        use math_lib
+        use optics_lib
+        use radar_simulator_types
+        implicit none
+        ! ----- INPUTS -----  
+        type(mie), intent(in) :: mt
+        type(class_param) :: hp
+        real*8, intent(in) :: freq,k2
+        integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
+            nhclass,nprof,ngate,nsizes
+        real*8, dimension(nsizes), intent(in) :: D
+        real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
+            t_matrix,rh_matrix
+        real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
+        real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
+        ! ----- OUTPUTS -----
+        real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
+            g_atten_to_vol,dBZe,h_atten_to_vol    
+        ! ----- OPTIONAL -----
+        real*8, optional, dimension(ngate,nprof) :: &
+            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(in) :: 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 :: &
+  freq, &			! radar frequency (GHz)
+  k2 				! |K|^2, -1=use frequency dependent default
+  
+  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
+
+  integer, parameter :: one = 1
+  logical :: hgt_reversed
+  integer :: pr,i,j,k,unt
+
+! ----- main program settings ------
+
+  freq = gbx%radar_freq
+  k2 = gbx%k2
+ 
+  !
+  ! note:  intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008
+  !
+  mt_ttl=gbx%mt_ttl  ! these variables really should be moved into the mt structure rather than kept as global arrays.
+  mt_tti=gbx%mt_tti
+
+  ! 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))
+
+  ! 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%Nlevels,gbx%Npoints))
+  
+  p_matrix   = gbx%p/100.0     ! From Pa to hPa
+  hgt_matrix = gbx%zlev/1000.0 ! From m to km
+  t_matrix   = gbx%T-273.15    ! From K to C
+  rh_matrix  = gbx%q
+  re_matrix  = 0.0
+  
+  ! Quickbeam assumes the first row is closest to the radar
+  call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
+      rh_matrix,gbx%surface_radar,hgt_reversed)
+  
+  ! ----- loop over subcolumns -----
+  do pr=1,sgx%Ncolumns
+      !  atmospheric profiles are the same within the same gridbox
+      !  only hydrometeor profiles will be different
+      if (hgt_reversed) then  
+         do i=1,gbx%Nhydro  
+            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg
+            if (gbx%use_reff) then
+              re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6     ! Units from m to micron
+            endif
+         enddo  
+      else  
+         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
+            endif
+         enddo
+      endif  
+
+      !   ----- call radar simulator -----
+      if (pr == 1) then ! Compute gaseous attenuation for all profiles
+         j=0
+         if (gbx%Npoints == 53) then
+           unt=10
+           j=1
+         endif
+         if (gbx%Npoints == 153) then
+           unt=11
+           j=101
+         endif
+         call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &    !  v0.2: mt changed to gbx%mt, roj
+           gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &                         !  v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj
+           hgt_matrix,hm_matrix,re_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(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &
+           gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &
+           hgt_matrix,hm_matrix,re_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
+      ! ----- BEGIN output section -----
+      ! spaceborne radar : from TOA to SURFACE
+      if (gbx%surface_radar == 1) then
+        z%Ze_tot(:,pr,:)=dBZe(:,:)
+      else if (gbx%surface_radar == 0) then ! Spaceborne
+        z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1)
+      endif
+
+  enddo !pr
+  
+  ! Change undefined value to one defined in COSP
+  where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF
+
+  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)
+ 
+  ! deallocate(mt_ttl,mt_tti)	!v0.2: roj feb 2008 can not be done here,
+                                !these variables now part of gbx structure and dealocated later
+
+END SUBROUTINE COSP_RADAR
+
+END MODULE MOD_COSP_RADAR
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_simulator.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_simulator.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_simulator.F90	(revision 2298)
@@ -0,0 +1,96 @@
+! (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.
+
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+!
+!
+
+MODULE MOD_COSP_SIMULATOR
+  USE MOD_COSP_TYPES
+  USE MOD_COSP_RADAR
+  USE MOD_COSP_LIDAR
+  USE MOD_COSP_ISCCP_SIMULATOR
+  USE MOD_COSP_MISR_SIMULATOR
+  USE MOD_COSP_STATS
+  IMPLICIT NONE
+
+CONTAINS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE COSP_SIMULATOR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
+
+  ! Arguments
+  type(cosp_gridbox),intent(in) :: gbx      ! Grid-box inputs
+  type(cosp_subgrid),intent(in) :: sgx      ! Subgrid inputs
+  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
+  type(cosp_config),intent(in) :: cfg       ! Configuration options
+  type(cosp_vgrid),intent(in)   :: vgrid    ! Information on vertical grid of stats
+  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
+  type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator
+  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
+  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
+  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
+  ! Local variables
+  ! ***Timing variables (to be deleted in final version)
+  integer :: t0,t1,count_rate,count_max
+
+  !+++++++++ Radar model ++++++++++  
+  if (cfg%Lradar_sim) then
+    call cosp_radar(gbx,sgx,sghydro,sgradar)
+  endif
+  
+  !+++++++++ Lidar model ++++++++++
+  if (cfg%Llidar_sim) then
+    call cosp_lidar(gbx,sgx,sghydro,sglidar)
+  endif
+
+  
+  !+++++++++ ISCCP simulator ++++++++++
+  if (cfg%Lisccp_sim) then
+    call cosp_isccp_simulator(gbx,sgx,isccp)
+  endif
+  
+  !+++++++++ MISR simulator ++++++++++
+  if (cfg%Lmisr_sim) then
+    call cosp_misr_simulator(gbx,sgx,misr)
+  endif
+  
+
+  !+++++++++++ Summary statistics +++++++++++
+  if (cfg%Lstats) then
+    call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
+!    print *, '%%%%%%  Stats:', (t1-t0)*1.0/count_rate, ' s'
+  endif
+
+  
+END SUBROUTINE COSP_SIMULATOR
+
+END MODULE MOD_COSP_SIMULATOR
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_stats.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_stats.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_stats.F90	(revision 2298)
@@ -0,0 +1,254 @@
+! (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.
+
+!
+! 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
+!
+!
+MODULE MOD_COSP_STATS
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE MOD_LLNL_STATS
+  USE MOD_LMD_IPSL_STATS
+  IMPLICIT NONE
+
+CONTAINS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE COSP_STATS ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
+
+   ! Input arguments
+   type(cosp_gridbox),intent(in) :: gbx
+   type(cosp_subgrid),intent(in) :: sgx
+   type(cosp_config),intent(in)  :: cfg
+   type(cosp_sgradar),intent(in) :: sgradar
+   type(cosp_sglidar),intent(in) :: sglidar
+   type(cosp_vgrid),intent(in)   :: vgrid
+   ! Output arguments
+   type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar
+   type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar
+
+   ! Local variables
+   integer :: Npoints  !# of grid points
+   integer :: Nlevels  !# of levels
+   integer :: Nhydro   !# of hydrometeors
+   integer :: Ncolumns !# of columns
+   integer :: Nlr
+   logical :: ok_lidar_cfad = .false.
+   real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out
+   real,dimension(:,:),allocatable :: ph_c,betamol_c
+
+   Npoints  = gbx%Npoints
+   Nlevels  = gbx%Nlevels
+   Nhydro   = gbx%Nhydro
+   Ncolumns = gbx%Ncolumns
+   Nlr      = vgrid%Nlvgrid
+
+   if (cfg%Lcfad_Lidarsr532) ok_lidar_cfad=.true.
+
+   if (vgrid%use_vgrid) then ! Statistics in a different vertical grid
+        allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), &
+                 betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), &
+                 ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr))
+        Ze_out = 0.0
+        betatot_out  = 0.0
+        betamol_out= 0.0
+        betamol_c  = 0.0
+        ph_in(:,1,:)  = gbx%ph(:,:)
+        ph_out  = 0.0
+        ph_c    = 0.0
+        !++++++++++++ Radar CFAD ++++++++++++++++
+        if (cfg%Lradar_sim) then
+            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, &
+                                           Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.)
+            stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, &
+                                        DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH)
+        endif
+        !++++++++++++ Lidar CFAD ++++++++++++++++
+        if (cfg%Llidar_sim) then
+            betamol_in(:,1,:) = sglidar%beta_mol(:,:)
+            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, &
+                                           Nlr,vgrid%zl,vgrid%zu,betamol_out)
+            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, &
+                                           Nlr,vgrid%zl,vgrid%zu,betatot_out)
+            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, &
+                                           Nlr,vgrid%zl,vgrid%zu,ph_out)
+            ph_c(:,:) = ph_out(:,1,:)
+            betamol_c(:,:) = betamol_out(:,1,:)
+            ! Stats from lidar_stat_summary
+            call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
+                            ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
+                            ,LIDAR_UNDEF,ok_lidar_cfad &
+                            ,stlidar%cfad_sr,stlidar%srbval &
+                            ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
+        endif
+        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
+        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
+                                    betatot_out,betamol_c,Ze_out, &
+                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
+        ! Deallocate arrays at coarse resolution
+        deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c)
+   else ! Statistics in model levels
+        !++++++++++++ Radar CFAD ++++++++++++++++
+        if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, &
+                                        DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH)
+        !++++++++++++ Lidar CFAD ++++++++++++++++
+        ! Stats from lidar_stat_summary
+        if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
+                        ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
+                        ,LIDAR_UNDEF,ok_lidar_cfad &
+                        ,stlidar%cfad_sr,stlidar%srbval &
+                        ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
+        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
+        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
+                                    sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, &
+                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
+   endif
+   ! Replace undef
+   where (stlidar%cfad_sr   == LIDAR_UNDEF) stlidar%cfad_sr   = R_UNDEF
+   where (stlidar%lidarcld  == LIDAR_UNDEF) stlidar%lidarcld  = R_UNDEF
+   where (stlidar%cldlayer  == LIDAR_UNDEF) stlidar%cldlayer  = R_UNDEF
+   where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF
+
+END SUBROUTINE COSP_STATS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,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,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer)
+   real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
+   integer,intent(in) :: M  !# levels in the new grid
+   real,dimension(M),intent(in) :: zl ! Lower boundary of new levels  [m]
+   real,dimension(M),intent(in) :: zu ! Upper boundary of new levels  [m]
+   logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
+   ! Output
+   real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid
+
+   ! Local variables
+   integer :: i,j,k
+   logical :: lunits
+
+   integer :: l
+   real,dimension(Npoints) :: ws,sumwyp
+   real,dimension(Npoints,Nlevels) :: xl,xu
+   real,dimension(Npoints,Nlevels) :: w
+   real,dimension(Npoints,Ncolumns,Nlevels) :: yp
+
+   lunits=.false.
+   if (present(log_units)) lunits=log_units
+
+   r(:,:,:) = R_GROUND
+   ! Vertical grid at that point
+   xl(:,:) = zhalf(:,:)
+   xu(:,1:Nlevels-1) = xl(:,2:Nlevels)
+   xu(:,Nlevels) = zfull(:,Nlevels) +  zfull(:,Nlevels) - zhalf(:,Nlevels) ! Top level symmetric
+   yp(:,:,:) = y(:,:,:) ! Temporary variable to regrid
+   ! Check for dBZ and change if necessary
+   if (lunits) then
+     where (y /= R_UNDEF)
+       yp = 10.0**(y/10.0)
+     elsewhere
+       yp = 0.0
+     end where
+   endif
+   do k=1,M
+     ! Find weights
+     w(:,:) = 0.0
+     do j=1,Nlevels
+       do i=1,Npoints
+         if ((xl(i,j) < zl(k)).and.(xu(i,j) > zl(k)).and.(xu(i,j) <= zu(k))) then
+           !xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = xu(i,j) - zl(k)
+         else if ((xl(i,j) >= zl(k)).and.(xu(i,j) <= zu(k))) then
+           !           xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = xu(i,j) - xl(i,j)
+         else if ((xl(i,j) >= zl(k)).and.(xl(i,j) < zu(k)).and.(xu(i,j) >= zu(k))) then
+           !                           xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = zu(k) - xl(i,j)
+         else if ((xl(i,j) <= zl(k)).and.(xu(i,j) >= zu(k))) then
+           !  xl(j)---------------------------xu(j)
+           !        zl(k)--------------zu(k)
+           w(i,j) = zu(k) - zl(k)
+         endif
+       enddo
+     enddo
+     ! Do the weighted mean
+     do j=1,Ncolumns
+       ws    (:) = 0.0
+       sumwyp(:) = 0.0
+       do l=1,Nlevels
+         do i=1,Npoints
+           if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
+             ws    (i) = ws    (i) + w(i,l)
+             sumwyp(i) = sumwyp(i) + w(i,l)*yp(i,j,l)
+           endif
+         enddo
+       enddo
+       do i=1,Npoints
+         if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
+           if (ws(i) > 0.0) r(i,j,k) = sumwyp(i)/ws(i)
+         endif
+       enddo
+     enddo
+   enddo
+   ! Check for dBZ and change if necessary
+   if (lunits) then
+     do k=1,M
+       do j=1,Ncolumns
+         do i=1,Npoints
+           if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
+             if (r(i,j,k) <= 0.0) then
+                 r(i,j,k) = R_UNDEF
+             else
+                 r(i,j,k) = 10.0*log10(r(i,j,k))
+             endif
+           endif
+         enddo
+       enddo
+     enddo
+   endif
+
+
+
+END SUBROUTINE COSP_CHANGE_VERTICAL_GRID
+
+END MODULE MOD_COSP_STATS
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_types.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_types.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_types.F90	(revision 2298)
@@ -0,0 +1,1379 @@
+! (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.
+
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+! Feb 2008 - R. Marchand      - Added Quickbeam types and initialisation
+! Oct 2008 - H. Chepfer       - Added PARASOL reflectance diagnostic
+! Nov 2008 - R. Marchand      - Added MISR diagnostics
+! Nov 2008 - V. John          - Added RTTOV diagnostics
+!
+! 
+MODULE MOD_COSP_TYPES
+    USE MOD_COSP_CONSTANTS
+    USE MOD_COSP_UTILS
+
+    use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice	! added by roj Feb 2008
+
+    IMPLICIT NONE
+    
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------------------- DERIVED TYPES ----------------------------    
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+  ! Configuration choices (simulators, variables)
+  TYPE COSP_CONFIG
+     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
+                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+                Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
+                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
+                Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+                Lfrac_out,Lbeta_mol532,Ltbrttov
+     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
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    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 
+    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
+    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level lidar cloud cover
+    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
+    real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance
+
+  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]
+  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
+    
+    ! 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
+    type(mie)::  mt		! structure used by radar simulator to store mie LUT information
+    integer :: nsizes 		! number of discrete drop sizes (um) used to represent the distribution
+    real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution
+    real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT)
+    
+    ! 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 
+    
+    ! Geolocation (Npoints)
+    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 :: sfc_height  ! Surface height [m]
+    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)
+    real,dimension(:,:,:),pointer :: Reff
+    ! 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(Npoints,Nchan,x)
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Nchan ! Number of channels
+    type(cosp_rttov),intent(out) :: x
+    
+    ! Dimensions
+    x%Npoints  = Npoints
+    x%Nchan    = Nchan
+      
+    ! --- Allocate arrays ---
+    allocate(x%tbs(Npoints, Nchan))
+    ! --- 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))
+    ! --- Initialise to zero ---
+    x%beta_mol   = 0.0
+    x%beta_tot   = 0.0
+    x%tau_tot    = 0.0
+    x%refl       = 0.0 ! parasol
+  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)
+  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))
+    ! --- Initialise to zero ---
+    x%srbval    = 0.0
+    x%cfad_sr   = 0.0
+    x%lidarcld  = 0.0
+    x%cldlayer  = 0.0
+    x%parasolrefl  = 0.0
+  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)
+  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))
+    ! --- Initialise to zero ---
+    y%mr_hydro = 0.0
+    y%Reff     = 0.0
+
+  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)
+        
+  END SUBROUTINE FREE_COSP_SGHYDRO
+ 
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,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)
+    double precision,intent(in) :: time ! Time since start of run [days] 
+    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
+
+        
+    ! local variables
+    integer i, cnt_ice, cnt_liq
+    character*200 :: mie_table_name ! Mie table name  
+    real*8  :: delt, deltp
+ 
+    ! 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
+    
+    ! 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%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
+             y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(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))
+    ! 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%mr_ozone  = 0.0
+    y%u_wind    = 0.0
+    y%v_wind    = 0.0
+
+    
+    ! (Npoints)
+!     call zero_real(y%psfc, y%land)
+    y%longitude = 0.0
+    y%latitude = 0.0
+    y%psfc = 0.0
+    y%land = 0.0
+    y%sunlit = 0.0
+    y%skt = 0.0
+    y%sfc_height = 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)
+
+    y%hp%p1 = 0.0
+    y%hp%p2 = 0.0
+    y%hp%p3 = 0.0
+    y%hp%dmin = 0.0
+    y%hp%dmax = 0.0
+    y%hp%apm = 0.0
+    y%hp%bpm = 0.0
+    y%hp%rho = 0.0
+    y%hp%dtype = 0
+    y%hp%col = 0
+    y%hp%cp = 0
+    y%hp%phase = 0
+    y%hp%scaled = .false.
+    y%hp%z_flag = .false.
+    y%hp%Ze_scaled = 0.0
+    y%hp%Zr_scaled = 0.0
+    y%hp%kr_scaled = 0.0
+    y%hp%fc = 0.0
+    y%hp%rho_eff = 0.0
+    y%hp%ifc = 0
+    y%hp%idd = 0
+    y%mt%freq = 0.0
+    y%mt%tt = 0.0
+    y%mt%f = 0.0
+    y%mt%D = 0.0
+    y%mt%qext = 0.0
+    y%mt%qbsca = 0.0
+    y%mt%phase = 0
+    
+    
+    ! --- Initialize the distributional parameters for hydrometeors
+    y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:)
+    y%dist_prmts_hydro( 2,:) = HCLASS_COL(:)
+    y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:)
+    y%dist_prmts_hydro( 4,:) = HCLASS_CP(:)
+    y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:)
+    y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:)
+    y%dist_prmts_hydro( 7,:) = HCLASS_APM(:)
+    y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:)
+    y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:)
+    y%dist_prmts_hydro(10,:) = HCLASS_P1(:)
+    y%dist_prmts_hydro(11,:) = HCLASS_P2(:)
+    y%dist_prmts_hydro(12,:) = HCLASS_P3(:)
+
+    ! the following code added by roj to initialize structures used by radar simulator, Feb 2008
+    call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro)
+
+    ! load mie tables ?
+    if (y%use_mie_tables == 1) then
+
+        ! ----- Mie tables ----
+  	    mie_table_name='mie_table.dat'
+        call load_mie_table(mie_table_name,y%mt)
+	
+	    !   :: D specified by table ... not must match that used when mie LUT generated!
+    	y%nsizes = mt_nd
+    	allocate(y%D(y%nsizes))
+    	y%D = y%mt%D
+
+    else
+	   ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table)
+	   
+	   cnt_ice=19
+	   cnt_liq=20
+       if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then
+          allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))  ! note needed as this is global array ... 
+                                                     ! which should be changed in the future
+       endif
+		  
+	   do i=1,cnt_ice
+		  mt_tti(i)=(i-1)*5-90
+	   enddo
+    
+	   do i=1,cnt_liq
+		  mt_ttl(i)=(i-1)*5 - 60
+	   enddo 
+    
+	   allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice))
+
+       y%mt_ttl = mt_ttl
+       y%mt_tti = mt_tti
+
+! !------ OLD code in v0.1 ---------------------------
+!        allocate(mt_ttl(2),mt_tti(2))
+!        allocate(y%mt_ttl(2),y%mt_tti(2))
+!        mt_ttl = 0.0
+!        mt_tti = 0.0
+!        y%mt_ttl = mt_ttl
+!        y%mt_tti = mt_tti
+! !---------------------------------------------------
+       
+       ! :: D created on a log-linear scale
+       y%nsizes = nd
+       delt = (log(dmax)-log(dmin))/(y%nsizes-1)
+       deltp = exp(delt)
+       allocate(y%D(y%nsizes))
+       y%D(1) = dmin
+       do i=2,y%nsizes
+          y%D(i) = y%D(i-1)*deltp
+       enddo   
+   
+    endif
+
+
+END SUBROUTINE CONSTRUCT_COSP_GRIDBOX
+
+  
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal)
+    type(cosp_gridbox),intent(inout) :: y
+    logical,intent(in),optional :: dglobal
+
+    ! --- Free arrays ---
+    deallocate(y%D,y%mt_ttl,y%mt_tti)	! added by roj Feb 2008
+    if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti)
+    
+!     deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, &
+!               y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, &
+!               y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, &
+!               y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd)
+!     deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase)
+    
+    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%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%sfc_height, y%Reff,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
+    y%hp%idd     = x%hp%idd
+    sz = shape(x%hp%z_flag)
+    do k=1,sz(3)
+      do j=1,sz(2)
+        do i=1,sz(1)
+           if (x%hp%scaled(i,k))   y%hp%scaled(i,k)      = .true.
+           if (x%hp%z_flag(i,j,k)) y%hp%z_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
+    
+    integer :: i,j,k,sz(3)
+    
+    ! --- Copy arrays without Npoints as dimension ---
+    y%dist_prmts_hydro = x%dist_prmts_hydro
+    y%dist_type_aero   = x%dist_type_aero
+    y%D                = x%D
+    y%mt_ttl           = x%mt_ttl
+    y%mt_tti           = x%mt_tti
+    
+    
+!     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%sfc_height(iy(1):iy(2)) = x%sfc_height(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%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%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),:)
+END SUBROUTINE COSP_LIDARSTATS_CPSECTION
+
+END MODULE MOD_COSP_TYPES
Index: LMDZ5/branches/testing/libf/phylmd/cosp/cosp_utils.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/cosp_utils.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/cosp_utils.F90	(revision 2298)
@@ -0,0 +1,336 @@
+! (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.
+
+!
+! 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, &
+                          flux,mxratio)
+
+    ! 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,prec_type
+    ! Input arguments, (OUT)
+    real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
+    ! Local variables
+    integer :: i,j,k
+    real :: sigma,one_over_xip1,xi,rho0,rho
+    
+    mxratio = 0.0
+
+    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
+        !gamma1  = gamma(alpha_x + b_x + d_x + 1.0)
+        !gamma2  = gamma(alpha_x + b_x + 1.0)
+        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)
+        
+        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
+                    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: LMDZ5/branches/testing/libf/phylmd/cosp/dsd.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/dsd.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/dsd.F90	(revision 2298)
@@ -0,0 +1,359 @@
+  subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, &
+             dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled)
+  use array_lib
+  use math_lib 
+  implicit none
+
+! Purpose:
+!   Create a discrete drop size distribution
+!   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 default.
+!   [D]        discrete drop sizes (um)
+!   [nsizes]   number of elements of [D]
+!   [dtype]    distribution type
+!   [rho_a]    ambient air density (kg m^-3)
+!   [tc]       temperature (C)
+!   [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:
+!   [fc]       scaling factor for the distribution
+!   [scaled]   has this hydrometeor type been scaled?
+!   [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)
+ 
+! ----- INPUTS -----  
+  
+  integer*4, intent(in) :: nsizes
+  integer, intent(in) :: dtype
+  real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, &
+    rho_c,p1,p2,p3
+    
+! ----- INPUT/OUTPUT -----
+
+  real*8, intent(inout) :: fc(nsizes),apm,bpm,Re
+  logical, intent(inout) :: scaled  
+    
+! ----- OUTPUTS -----
+
+  real*8, intent(out) :: N(nsizes)
+  
+! ----- INTERNAL -----
+  
+  real*8 :: &
+  N0,D0,vu,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
+
+  integer k,lidx,uidx
+
+  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
+  
+  select case(dtype)
+  
+! ---------------------------------------------------------!
+! // modified gamma                                        !
+! ---------------------------------------------------------!
+! :: N0 = total number concentration (m^-3)
+! :: np = fixed number concentration (kg^-1)
+! :: D0 = characteristic diameter (um)
+! :: dm = mean diameter (um)
+! :: vu = distribution width parameter
+
+  case(1)  
+    if (abs(p1+1) < 1E-8) then
+
+!     // D0, vu are given  
+      vu = p3 
+      
+      if(Re.le.0) then 
+      	dm = p2
+	D0 = gamma(vu)/gamma(vu+1)*dm
+      else
+	D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
+      endif
+     
+      if (scaled .eqv. .false.) then
+      
+        fc = ( &
+             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
+	     ) * 1E-12
+	scaled = .true.
+
+      endif	   
+
+      N = fc*rho_a*(Q*1E-3)
+    
+    elseif (abs(p2+1) < 1E-8) then
+
+!     // N0, vu are given    
+      np = p1
+      vu = p3 
+      tmp1 = (Q*1E-3)**(1./bpm)
+      
+      if (scaled .eqv. .false.) then
+
+        fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** &
+             (1./bpm))**vu
+	     
+        scaled = .true.
+
+      endif
+
+      N = ( &
+          (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
+          exp(-1.*fc**(1./vu)/tmp1) &
+ 	  ) * 1E-12
+
+    else
+
+!     // vu isn't given
+      print *, 'Error: Must specify a value for vu'
+      stop
+    
+    endif
+    
+! ---------------------------------------------------------!
+! // exponential                                           !
+! ---------------------------------------------------------!
+! :: N0 = intercept parameter (m^-4)
+! :: ld = slope parameter (um)
+
+  case(2)
+    if (abs(p1+1) > 1E-8) then
+
+!     // N0 has been specified, determine ld
+      N0 = p1
+
+      if(Re>0) then
+
+	! if Re is set and No is set than the distribution is fully defined.
+	! so we assume Re and No have already been chosen consistant with  
+	! the water content, Q.
+
+	! print *,'using Re pass ...'
+
+	ld = 1.5/Re   ! units 1/um
+
+	N = ( &
+          	N0*exp(-1*ld*D) &
+        ) * 1E-12
+    
+      else
+
+      	tmp1 = 1./(1.+bpm)
+      
+      	if (scaled .eqv. .false.) then
+        	fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
+		scaled = .true.
+
+      	endif
+     
+      	N = ( &
+        	N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
+	) * 1E-12
+
+      endif	
+
+    elseif (abs(p2+1) > 1E-8) then
+
+!     // ld has been specified, determine N0
+      ld = p2
+
+      if (scaled .eqv. .false.) then
+
+        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
+             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
+        scaled = .true.
+
+      endif
+
+      N = fc*rho_a*(Q*1E-3)
+
+    else
+
+!     // ld will be determined from temperature, then N0 follows
+      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)
+
+!   :: 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 (scaled .eqv. .false.) then
+    
+      D0 = p1
+      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
+      fc(1) = (6./(pi*D0**3*rho_e))*1E12
+      scaled = .true.
+      
+    endif
+    
+    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) 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
+ 
+      if (scaled .eqv. .false.) then
+            
+        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
+	scaled = .true.
+	     
+      endif
+	        
+      N = fc*rho_a*(Q*1E-3)
+      
+    elseif (abs(p2+1) < 1E-8) then
+
+!     // N0, log_sigma_g are given    
+      Np = p1
+      log_sigma_g = p3
+      N0 = 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
+
+!     // vu isn't given
+      print *, 'Error: Must specify a value for sigma_g'
+      stop
+    
+    endif
+    
+  end select
+  
+  end subroutine dsd
Index: LMDZ5/branches/testing/libf/phylmd/cosp/format_input.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/format_input.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/format_input.F90	(revision 2298)
@@ -0,0 +1,132 @@
+! 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: LMDZ5/branches/testing/libf/phylmd/cosp/gases.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/gases.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/gases.F90	(revision 2298)
@@ -0,0 +1,182 @@
+  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
+  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
+
+! // term1
+  sumo = 0.
+  do i=1,nbands_o2
+    sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) &
+           * s_o2(p,th,a1(i),a2(i))
+  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.
+  do i=1,nbands_h2o
+    sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) &
+           * s_h2o(th,e,b1(i),b2(i))
+  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
+
+! ----- SUB FUNCTIONS -----
+    
+  contains
+  
+  function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0)
+  real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0
+  real*8 :: gm, delt, x, y
+  gm = a3*(p*th**(0.8-a4)+1.1*e*th)
+  delt = a5*p*th**(a6)
+  x = (v0-f)**2+gm**2
+  y = (v0+f)**2+gm**2
+  fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))  
+  end function fpp_o2
+  
+  function fpp_h2o(p,th,e,b3,f,v0)
+  real*8 :: fpp_h2o,p,th,e,b3,f,v0
+  real*8 :: gm, delt, x, y
+  gm = b3*(p*th**(0.8)+4.8*e*th)
+  delt = 0.
+  x = (v0-f)**2+gm**2
+  y = (v0+f)**2+gm**2
+  fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))
+  end function fpp_h2o
+  
+  function s_o2(p,th,a1,a2)
+  real*8 :: s_o2,p,th,a1,a2
+  s_o2 = a1*p*th**(3)*exp(a2*(1-th))
+  end function s_o2
+
+  function s_h2o(th,e,b1,b2)
+  real*8 :: s_h2o,th,e,b1,b2
+  s_h2o = b1*e*th**(3.5)*exp(b2*(1-th))
+  end function s_h2o
+  
+  end function gases
Index: LMDZ5/branches/testing/libf/phylmd/cosp/icarus.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/icarus.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/icarus.F	(revision 2298)
@@ -0,0 +1,1268 @@
+      SUBROUTINE ICARUS(
+     &     debug,
+     &     debugcol,
+     &     npoints,
+     &     sunlit,
+     &     nlev,
+     &     ncol,
+     &     pfull,
+     &     phalf,
+     &     qv,
+     &     cc,
+     &     conv,
+     &     dtau_s,
+     &     dtau_c,
+     &     top_height,
+     &     top_height_direction,
+     &     overlap,
+     &     frac_out,
+     &     skt,
+     &     emsfc_lw,
+     &     at,
+     &     dem_s,
+     &     dem_c,
+     &     fq_isccp,
+     &     totalcldarea,
+     &     meanptop,
+     &     meantaucld,
+     &     meanalbedocld,
+     &     meantb,
+     &     meantbclr,
+     &     boxtau,
+     &     boxptop
+     &)
+
+!$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $
+
+! *****************************COPYRIGHT****************************
+! (c) 2009, 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:
+! 
+!     * 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.  
+! 
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+
+      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
+      INTEGER nlev          !  number of model levels in column
+      INTEGER ncol          !  number of subcolumns
+
+      INTEGER sunlit(npoints) !  1 for day points, 0 for night time
+
+      REAL pfull(npoints,nlev)
+                       !  pressure of full model levels (Pascals)
+                  !  pfull(npoints,1) is top level of model
+                  !  pfull(npoints,nlev) is bot 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)
+
+      INTEGER 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 = old setting: matches all versions of 
+				 ! ISCCP simulator with versions numbers 3.5.1 and lower
+				 !
+				 ! 2 = default setting: for version numbers 4.0 and higher
+!
+!     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.
+
+      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
+
+
+
+!     ------
+!     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.  NOTE: This diagnostic
+					! does not count model clouds with tau < isccp_taumin
+                              ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
+			      ! However, this diagnostic does equal the sum over entries of fq_isccp with
+			      ! itau = 2:7 (omitting itau = 1)
+      
+      
+      ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.  
+      ! If no clouds with tau > isccp_taumin 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 meanalbedocld(npoints)        ! mean cloud albedo
+                                        ! linear averaging in albedo performed
+					
+      real meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
+      
+      real meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
+      
+      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 dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave 
+                              !  emissivity in part of
+                              !  gridbox under consideration
+
+      REAL ptrop(npoints)
+      REAL attrop(npoints)
+      REAL attropmin (npoints)
+      REAL atmax(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 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 rangevec(npoints),rangeerror
+
+      integer index1(npoints),num1,jj,k1,k2
+      real rec2p13,tauchk,logp,logp1,logp2,atd
+      real output_missing_value
+
+      character*10 ftn09
+      
+      DATA isccp_taumin / 0.3 /
+      DATA output_missing_value / -1.E+30 /
+      DATA cchar / ' ','-','1','+','I','+'/
+      DATA cchar_realtops / ' ',' ','1','1','I','I'/
+
+!     ------ End duplicate definitions common to wrapper routine
+
+      tauchk = -1.*log(0.9999999)
+      rec2p13=1./2.13
+
+      ncolprint=0
+
+      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,'(a11)') 'top_height='
+          write(6,'(8I10)') top_height
+	  write(6,'(a21)') 'top_height_direction='
+          write(6,'(8I10)') top_height_direction
+          write(6,'(a10)') 'overlap='
+          write(6,'(8I10)') overlap
+          write(6,'(a10)') 'emsfc_lw='
+          write(6,'(8f10.2)') emsfc_lw
+        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)') '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.3)') (dem_c(j,i),i=1,nlev)
+        enddo
+      endif
+
+!     ---------------------------------------------------!
+
+      if (ncolprint.ne.0) then
+      do j=1,npoints,1000
+        write(6,'(a10)') 'j='
+        write(6,'(8I10)') j
+      enddo
+      endif
+
+      if (top_height .eq. 1 .or. top_height .eq. 3) then 
+
+      do j=1,npoints 
+          ptrop(j)=5000.
+          attropmin(j) = 400.
+          atmax(j) = 0.
+          attrop(j) = 120.
+          itrop(j) = 1
+      enddo 
+
+      do 12 ilev=1,nlev
+        do j=1,npoints 
+         if (pfull(j,ilev) .lt. 40000. .and.
+     &          pfull(j,ilev) .gt.  5000. .and.
+     &          at(j,ilev) .lt. attropmin(j)) then
+                ptrop(j) = pfull(j,ilev)
+                attropmin(j) = at(j,ilev)
+                attrop(j) = attropmin(j)
+                itrop(j)=ilev
+           end if
+        enddo
+12    continue
+
+      do 13 ilev=1,nlev
+        do j=1,npoints 
+           if (at(j,ilev) .gt. atmax(j) .and.
+     &              ilev  .ge. itrop(j)) atmax(j)=at(j,ilev)
+        enddo
+13    continue
+
+      end if
+
+
+      if (top_height .eq. 1 .or. top_height .eq. 3) then
+          do j=1,npoints
+              meantb(j) = 0.
+	      meantbclr(j) = 0. 
+          end do
+      else
+          do j=1,npoints
+              meantb(j) = output_missing_value
+       	      meantbclr(j) = output_missing_value
+          end do
+      end if
+      
+!     -----------------------------------------------------!
+
+!     ---------------------------------------------------!
+
+      do ilev=1,nlev
+        do j=1,npoints
+
+          rangevec(j)=0
+
+          if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
+!           error = cloud fraction less than zero
+!           error = cloud fraction greater than 1
+            rangevec(j)=rangevec(j)+1
+          endif
+
+          if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
+!           ' error = convective cloud fraction less than zero'
+!           ' error = convective cloud fraction greater than 1'
+            rangevec(j)=rangevec(j)+2
+          endif
+
+          if (dtau_s(j,ilev) .lt. 0.) then
+!           ' error = stratiform cloud opt. depth less than zero'
+            rangevec(j)=rangevec(j)+4
+          endif
+
+          if (dtau_c(j,ilev) .lt. 0.) then
+!           ' error = convective cloud opt. depth less than zero'
+            rangevec(j)=rangevec(j)+8
+          endif
+
+          if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
+!             ' error = stratiform cloud emissivity less than zero'
+!             ' error = stratiform cloud emissivity greater than 1'
+            rangevec(j)=rangevec(j)+16
+          endif
+
+          if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
+!             ' error = convective cloud emissivity less than zero'
+!             ' error = convective cloud emissivity greater than 1'
+              rangevec(j)=rangevec(j)+32
+          endif
+        enddo
+
+        rangeerror=0
+        do j=1,npoints
+            rangeerror=rangeerror+rangevec(j)
+        enddo
+
+        if (rangeerror.ne.0) then 
+              write (6,*) 'Input variable out of range'
+              write (6,*) 'rangevec:'
+              write (6,*) rangevec
+              STOP
+        endif
+      enddo
+
+!
+!     ---------------------------------------------------!
+
+      
+!
+!     ---------------------------------------------------!
+!     COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
+!     put into vector tau
+ 
+      !initialize tau and albedocld to zero
+      do 15 ibox=1,ncol
+        do j=1,npoints 
+            tau(j,ibox)=0.
+          albedocld(j,ibox)=0.
+          boxtau(j,ibox)=output_missing_value
+          boxptop(j,ibox)=output_missing_value
+          box_cloudy(j,ibox)=.false.
+        enddo
+15    continue
+
+      !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 
+                 if (frac_out(j,ibox,ilev).eq.1) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_s(j,ilev)
+                 endif
+                 if (frac_out(j,ibox,ilev).eq.2) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_c(j,ilev)
+                 end if
+              enddo
+            enddo ! ibox
+      enddo ! ilev
+          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 .eq. 1 .or. top_height .eq. 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.
+        if (ncolprint .ne. 0) 
+     &         write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
+        do 125 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))
+          enddo
+               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
+125     continue
+
+        !initialize variables
+        do j=1,npoints 
+          fluxtop_clrsky(j) = 0.
+          trans_layers_above_clrsky(j)=1.
+        enddo
+
+        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))
+                   
+
+          enddo   
+            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
+
+        enddo   !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)
+     
+          !clear sky brightness temperature
+          meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
+	  
+        enddo
+
+        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,'(5(f7.2,1X))') emsfc_lw,100.*bb(j),
+     &      100.*fluxtop_clrsky(j),
+     &       trans_layers_above_clrsky(j), meantbclr(j)
+        enddo
+      endif
+    
+
+        !
+        !           END OF CLEAR SKY CALCULATION
+        !
+        !----------------------------------------------------------------
+
+
+
+        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.
+          enddo
+        enddo
+
+        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
+              enddo
+
+            do ibox=1,ncol
+              do j=1,npoints 
+
+              ! emissivity for point in this layer
+                if (frac_out(j,ibox,ilev).eq.1) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
+                else if (frac_out(j,ibox,ilev).eq.2) 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))
+
+              enddo ! j
+            enddo ! ibox
+
+            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
+
+        enddo ! 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
+
+        !calculate mean infrared brightness temperature
+        do ibox=1,ncol
+          do j=1,npoints 
+            meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
+	  end do
+        end do
+	  do j=1, npoints
+	    meantb(j) = meantb(j) / real(ncol)
+	  end do        
+
+        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)
+          
+	  write (6,'(a)') 'meantb(j):'
+          write (6,'(8f7.2)') (meantb(j),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. ) 
+          enddo 
+        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))
+
+          enddo 
+
+          if (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) *rec2p13
+              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. - 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) .gt. 260.) then
+                  tauir(j) = tau(j,ibox) / 2.56
+                  end if                   
+                end if
+                end if
+              enddo
+            enddo
+                
+          endif
+        
+          do j=1,npoints
+            if (tau(j,ibox) .gt. (tauchk            )) then 
+                !cloudy box 
+		!NOTE: tb is the cloud-top temperature not infrared brightness temperature 
+		!at this point in the code
+                tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
+                if (top_height.eq.1.and.tauir(j).lt.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) = meantbclr(j)
+            end if
+          enddo ! j
+        enddo ! ibox
+
+        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 30 ibox=1,ncol
+        !segregate according to optical thickness
+        if (top_height .eq. 1 .or. top_height .eq. 3) then  
+          !find level whose temperature
+          !most closely matches brightness temperature
+          do j=1,npoints 
+            nmatch(j)=0
+          enddo
+          do 29 k1=1,nlev-1
+	    if (top_height_direction .eq. 2) then
+	      ilev = nlev - k1 
+	    else
+	      ilev = k1
+	    end if
+            !cdir nodep
+            do j=1,npoints 
+	     if (ilev .ge. itrop(j)) then
+              if ((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
+              end if  
+	     end if                         
+            enddo
+29        continue
+
+          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)
+	      if(abs(pfull(j,k1)-ptop(j,ibox)) .lt.
+     &            abs(pfull(j,k2)-ptop(j,ibox))) then
+                 levmatch(j,ibox)=k1
+              else
+                 levmatch(j,ibox)=k2
+              end if   
+            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 ! j
+
+        else ! if (top_height .eq. 1 .or. top_height .eq. 3) 
+ 
+          do j=1,npoints     
+            ptop(j,ibox)=0.
+          enddo
+          do ilev=1,nlev
+            do j=1,npoints     
+              if ((ptop(j,ibox) .eq. 0. )
+     &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
+                ptop(j,ibox)=phalf(j,ilev)
+              levmatch(j,ibox)=ilev
+              end if
+            end do
+          end do
+        end if                            
+          
+        do j=1,npoints
+          if (tau(j,ibox) .le. (tauchk            )) then
+            ptop(j,ibox)=0.
+            levmatch(j,ibox)=0      
+          endif 
+        enddo
+
+30    continue
+              
+!
+!
+!     ---------------------------------------------------!
+
+
+!     
+!     ---------------------------------------------------!
+!     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 38 ilev=1,7
+      do 38 ilev2=1,7
+        do j=1,npoints ! 
+             if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+                fq_isccp(j,ilev,ilev2)= 0.
+	     else
+	        fq_isccp(j,ilev,ilev2)= output_missing_value
+	     end if
+        enddo
+38    continue
+
+      !reset variables need for averaging cloud properties
+      do j=1,npoints 
+        if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+             totalcldarea(j) = 0.
+             meanalbedocld(j) = 0.
+             meanptop(j) = 0.
+             meantaucld(j) = 0.
+	else
+             totalcldarea(j) = output_missing_value
+             meanalbedocld(j) = output_missing_value
+             meanptop(j) = output_missing_value
+             meantaucld(j) = output_missing_value
+	end if
+      enddo ! j
+
+      boxarea = 1./real(ncol)
+     
+      do 39 ibox=1,ncol
+        do j=1,npoints 
+
+          if (tau(j,ibox) .gt. (tauchk            )
+     &      .and. ptop(j,ibox) .gt. 0.) then
+              box_cloudy(j,ibox)=.true.
+          endif
+
+          if (box_cloudy(j,ibox)) then
+
+              if (sunlit(j).eq.1 .or. top_height .eq. 3) then
+
+                boxtau(j,ibox) = tau(j,ibox)
+
+		if (tau(j,ibox) .ge. isccp_taumin) then
+		   totalcldarea(j) = totalcldarea(j) + boxarea
+		
+                   !convert optical thickness to albedo
+                   albedocld(j,ibox)
+     &		   = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82)
+         
+                   !contribute to averaging
+                   meanalbedocld(j) = meanalbedocld(j) 
+     &                                +albedocld(j,ibox)*boxarea
+
+                end if
+
+            endif
+
+          endif
+
+          if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+
+           if (box_cloudy(j,ibox)) then
+          
+              !convert ptop to millibars
+              ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+              !save for output cloud top pressure and optical thickness
+              boxptop(j,ibox) = ptop(j,ibox)
+    
+              if (tau(j,ibox) .ge. isccp_taumin) then
+	      	meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
+              end if		
+
+              !reset itau(j), ipres(j)
+              itau(j) = 0
+              ipres(j) = 0
+
+              !determine optical depth category
+              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) .gt. 0.and.itau(j) .gt. 0) then
+              fq_isccp(j,itau(j),ipres(j))=
+     &          fq_isccp(j,itau(j),ipres(j))+ boxarea
+              end if
+
+            end if
+
+          end if
+                       
+        enddo ! j
+39    continue
+      
+      !compute mean cloud properties
+      do j=1,npoints 
+        if (totalcldarea(j) .gt. 0.) then
+	  ! code above guarantees that totalcldarea > 0 
+	  ! only if sunlit .eq. 1 .or. top_height = 3 
+	  ! and applies only to clouds with tau > isccp_taumin
+          meanptop(j) = meanptop(j) / totalcldarea(j)
+          meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
+          meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
+	else
+	  ! this code is necessary so that in the case that totalcldarea = 0.,
+	  ! that these variables, which are in-cloud averages, are set to missing
+	  ! note that totalcldarea will be 0. if all the clouds in the grid box have
+	  ! tau < isccp_taumin 
+	  meanptop(j) = output_missing_value
+          meanalbedocld(j) = output_missing_value
+          meantaucld(j) = output_missing_value
+        end if
+      enddo ! j
+!
+!     ---------------------------------------------------!
+
+!     ---------------------------------------------------!
+!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+!
+      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)
+
+             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 
+
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/lidar_simulator.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/lidar_simulator.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/lidar_simulator.F90	(revision 2298)
@@ -0,0 +1,571 @@
+! 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:
+! 
+!     * 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 &
+                , frac_out, ice_type &
+                , pmol, pnorm, 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. 
+!
+!---------------------------------------------------------------------------------
+!
+! 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)
+!  frac_out : cloud cover in each sub-column of the gridbox (output from scops)
+!  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)
+!  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)
+!---------------------------------------------------------------------------------
+
+      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 temp(npoints,nlev)
+      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)
+      REAL frac_out(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 frac_sub(npoints,nlev)
+      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
+
+! Abderrahmane 8-2-2011
+      Logical iflag_testlidar
+      PARAMETER (iflag_testlidar=.false.)
+
+!------------------------------------------------------------
+!---- 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
+
+! cloud fraction (0 or 1) in each sub-column:
+! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0)
+      frac_sub = MIN( frac_out, 1.0 )
+
+!------------------------------------------------------------
+!---- 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. 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(:)) &
+!correc          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) & ! correc Satoh
+!correc               &               / (2.0*tautot_lay(:)) &          ! correc Satoh
+               & * (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
+
+     if (iflag_testlidar) then
+!+JLD test 
+!     do k=1,nlev
+!      print*,'Min val de frac_out=',k,minval(frac_out(:,k))
+!      print*,'Max val de frac_out=',k,maxval(frac_out(:,k))
+!     enddo
+       where ( frac_out(:,:).ge.0.5)
+! Correction AI 9 5 11          pnorm(:,:) = pmol(:,:)*10.
+       pnorm(:,:) = pmol(:,:)*50.
+        elsewhere
+          pnorm(:,:) = pmol(:,:)
+        endwhere
+!-JLD test 
+     endif
+
+!-------- 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: LMDZ5/branches/testing/libf/phylmd/cosp/llnl_stats.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/llnl_stats.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/llnl_stats.F90	(revision 2298)
@@ -0,0 +1,135 @@
+! (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:
+! 
+!     * 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.
+
+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,beta_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) :: 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 = 3.0)  ! Previous thresold for cloud detection
+   parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
+   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 ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,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
+!             if ((pr == 1).and.(j==8)) print *, 'L'
+            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.)
+!            if ((pr == 1).and.(j==8)) print *, 'R'
+           flag_cld=1
+        endif
+       enddo !levels
+       if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
+     enddo !columns
+!      if (tcc(pr) > Ncolumns) then
+!      print *, 'tcc(',pr,'): ', tcc(pr)
+!      tcc(pr) = Ncolumns
+!      endif
+   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: LMDZ5/branches/testing/libf/phylmd/cosp/lmd_ipsl_stats.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/lmd_ipsl_stats.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/lmd_ipsl_stats.F90	(revision 2298)
@@ -0,0 +1,413 @@
+! 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:
+!
+!     * 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.
+
+
+!------------------------------------------------------------------------------------
+! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France).
+!------------------------------------------------------------------------------------
+MODULE MOD_LMD_IPSL_STATS
+  USE MOD_LLNL_STATS
+  IMPLICIT NONE
+
+CONTAINS
+      SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl &
+                  ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad &
+                  ,cfad2,srbval &
+                  ,ncat,lidarcld,cldlayer,parasolrefl)
+!
+! -----------------------------------------------------------------------------------
+! Lidar outputs :
+!
+! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction
+! from the lidar signals (ATB and molecular ATB) computed from model outputs
+!      +
+! Compute CFADs of lidar scattering ratio SR and of depolarization index
+!
+! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France).
+!
+! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne :
+! - change of the cloud detection threshold S_cld from 3 to 5, for better
+! with both day and night observations. The optical thinest clouds are missed.
+! - remove of the detection of the first fully attenuated layer encountered from above.
+! December 2008, A. Bodas-Salcedo:
+! - Dimensions of pmol reduced to (npoints,llm)
+! August 2009, A. Bodas-Salcedo:
+! - Warning message regarding PARASOL being valid only over ocean deleted.
+! February 2010, A. Bodas-Salcedo:
+! - Undef passed into cosp_cfad_sr
+! June 2010, T. Yokohata, T. Nishimura and K. Ogochi
+! Optimisation of COSP_CFAD_SR
+!
+! 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)
+! c------------------------------------------------------------------------------------
+
+! c inputs :
+      integer npoints
+      integer ncol
+      integer llm
+      integer max_bin               ! nb of bins for SR CFADs
+      integer ncat                  ! nb of cloud layer types (low,mid,high,total)
+      integer nrefl                 ! nb of solar zenith angles for parasol reflectances
+
+      real undef                    ! undefined value
+      real pnorm(npoints,ncol,llm)  ! lidar ATB
+      real pmol(npoints,llm)        ! molecular ATB
+      real land(npoints)            ! Landmask [0 - Ocean, 1 - Land]
+      real pplay(npoints,llm)       ! pressure on model levels (Pa)
+      logical ok_lidar_cfad         ! true if lidar CFAD diagnostics need to be computed
+      real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol
+
+! c outputs :
+      real lidarcld(npoints,llm)     ! 3D "lidar" cloud fraction
+      real cldlayer(npoints,ncat)    ! "lidar" cloud fraction (low, mid, high, total)
+      real cfad2(npoints,max_bin,llm) ! CFADs of SR
+      real srbval(max_bin)           ! SR bins in CFADs
+      real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance
+
+! c threshold for cloud detection :
+      real S_clr
+      parameter (S_clr = 1.2)
+      real S_cld
+!      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
+      parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
+      real S_att
+      parameter (S_att = 0.01)
+
+! c local variables :
+      integer ic,k
+      real x3d(npoints,ncol,llm)
+      real x3d_c(npoints,llm),pnorm_c(npoints,llm)
+      real xmax
+!
+! c -------------------------------------------------------
+! c 0- Initializations
+! c -------------------------------------------------------
+!
+
+!  Should be modified in future version
+      xmax=undef-1.0
+
+! c -------------------------------------------------------
+! c 1- Lidar scattering ratio :
+! c -------------------------------------------------------
+!
+!       where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 ))
+!          x3d = pnorm/pmol
+!       elsewhere
+!           x3d = undef
+!       end where
+! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08)
+      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 = undef
+        end where
+        x3d(:,ic,:) = x3d_c
+      enddo
+
+! c -------------------------------------------------------
+! c 2- Diagnose cloud fractions (3D, low, middle, high, total)
+! c from subgrid-scale lidar scattering ratios :
+! c -------------------------------------------------------
+
+      CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,  &
+              x3d,pplay, S_att,S_cld,undef,lidarcld, &
+              cldlayer)
+
+! c -------------------------------------------------------
+! c 3- CFADs
+! c -------------------------------------------------------
+      if (ok_lidar_cfad) then
+!
+! c CFADs of subgrid-scale lidar scattering ratios :
+! c -------------------------------------------------------
+      CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin,undef, &
+                 x3d, &
+                 S_att,S_clr,xmax,cfad2,srbval)
+
+      endif   ! ok_lidar_cfad
+! c -------------------------------------------------------
+
+! c -------------------------------------------------------
+! c 4- Compute grid-box averaged Parasol reflectances
+! c -------------------------------------------------------
+
+      parasolrefl(:,:) = 0.0
+
+      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=undef
+! if land=0 -> parasolrefl=parasolrefl
+        parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) &
+                           + (1.0 - MAX(1.0-land(:),0.0))*undef
+      enddo
+
+      RETURN
+      END SUBROUTINE diag_lidar
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!-------------------- FUNCTION COSP_CFAD_SR ------------------------
+! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris)
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins,undef, &
+                      x,S_att,S_clr,xmax,cfad,srbval)
+      IMPLICIT NONE
+
+!--- Input arguments
+! Npoints: Number of horizontal points
+! Ncolumns: Number of subcolumns
+! Nlevels: Number of levels
+! Nbins: Number of x axis bins
+! xmax: maximum value allowed for x
+! S_att: Threshold for full attenuation
+! S_clr: Threshold for clear-sky layer
+!
+!--- Input-Outout arguments
+! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs
+!
+! -- Output arguments
+! srbval : values of the histogram bins
+! cfad: 2D histogram on each horizontal point
+
+! Input arguments
+      integer Npoints,Ncolumns,Nlevels,Nbins
+      real xmax,S_att,S_clr,undef
+! Input-output arguments
+      real x(Npoints,Ncolumns,Nlevels)
+! Output :
+      real cfad(Npoints,Nbins,Nlevels)
+      real srbval(Nbins)
+! Local variables
+      integer i, j, k, ib
+      real srbval_ext(0:Nbins)
+
+! c -------------------------------------------------------
+! c 0- Initializations
+! c -------------------------------------------------------
+      if ( Nbins .lt. 6) return
+
+      srbval(1) =  S_att
+      srbval(2) =  S_clr
+      srbval(3) =  3.0
+      srbval(4) =  5.0
+      srbval(5) =  7.0
+      srbval(6) = 10.0
+      do i = 7, MIN(10,Nbins)
+       srbval(i) = srbval(i-1) + 5.0
+      enddo
+      DO i = 11, MIN(13,Nbins)
+       srbval(i) = srbval(i-1) + 10.0
+      enddo
+      srbval(MIN(14,Nbins)) = 80.0
+      srbval(Nbins) = xmax
+      cfad(:,:,:) = 0.0
+
+      srbval_ext(1:Nbins) = srbval
+      srbval_ext(0) = -1.0
+! c -------------------------------------------------------
+! c c- Compute CFAD
+! c -------------------------------------------------------
+
+      do j = 1, Nlevels
+         do ib = 1, Nbins
+            do k = 1, Ncolumns
+               do i = 1, Npoints
+                  if (x(i,k,j) /= undef) then
+                     if ((x(i,k,j).gt.srbval_ext(ib-1)).and.(x(i,k,j).le.srbval_ext(ib))) &
+                          cfad(i,ib,j) = cfad(i,ib,j) + 1.0
+                  else 
+                     cfad(i,ib,j) = undef
+                  endif
+               enddo
+            enddo
+         enddo
+      enddo
+
+      where (cfad .ne. undef)  cfad = cfad / float(Ncolumns)
+
+! c -------------------------------------------------------
+      RETURN
+      END SUBROUTINE COSP_CFAD_SR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!-------------------- SUBROUTINE COSP_CLDFRAC -------------------
+! c Purpose: Cloud fraction diagnosed from lidar measurements
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, &
+                  x,pplay,S_att,S_cld,undef,lidarcld, &
+                  cldlayer)
+      IMPLICIT NONE
+! Input arguments
+      integer Npoints,Ncolumns,Nlevels,Ncat
+      real x(Npoints,Ncolumns,Nlevels)
+      real pplay(Npoints,Nlevels)
+      real S_att,S_cld
+      real undef
+! Output :
+      real lidarcld(Npoints,Nlevels) ! 3D cloud fraction
+      real cldlayer(Npoints,Ncat)    ! low, middle, high, total cloud fractions
+! Local variables
+      integer ip, k, iz, ic
+      real p1
+      real cldy(Npoints,Ncolumns,Nlevels)
+      real srok(Npoints,Ncolumns,Nlevels)
+      real cldlay(Npoints,Ncolumns,Ncat)
+      real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat)
+      real nsub(Npoints,Nlevels)
+
+      real cldlay1(Npoints,Ncolumns)
+      real cldlay2(Npoints,Ncolumns)
+      real cldlay3(Npoints,Ncolumns)
+      real nsublay1(Npoints,Ncolumns)
+      real nsublay2(Npoints,Ncolumns)
+      real nsublay3(Npoints,Ncolumns)
+
+
+! ---------------------------------------------------------------
+! 1- initialization
+! ---------------------------------------------------------------
+
+      if ( Ncat .ne. 4 ) then
+         print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat
+         stop
+      endif
+
+      lidarcld = 0.0
+      nsub = 0.0
+      cldlay = 0.0
+      nsublay = 0.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.0
+         elsewhere
+           cldy(:,:,k)=0.0
+         endwhere
+
+! number of usefull sub-columns:
+         where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef)  )
+           srok(:,:,k)=1.0
+         elsewhere
+           srok(:,:,k)=0.0
+         endwhere
+
+      enddo ! k
+
+! ---------------------------------------------------------------
+! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure
+! categories) :
+! ---------------------------------------------------------------
+      lidarcld = 0.0
+      nsub = 0.0
+
+!! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts.
+      cldlay1 = 0.0
+      cldlay2 = 0.0
+      cldlay3 = 0.0
+      cldlay(:,:,4) = 0.0 !! XXX: Ncat == 4
+      nsublay1 = 0.0
+      nsublay2 = 0.0
+      nsublay3 = 0.0
+      nsublay(:,:,4) = 0.0
+      do k = Nlevels, 1, -1
+       do ic = 1, Ncolumns
+        do ip = 1, Npoints
+         p1 = pplay(ip,k)
+
+         if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds
+            cldlay3(ip,ic) = MAX(cldlay3(ip,ic), cldy(ip,ic,k))
+            nsublay3(ip,ic) = MAX(nsublay3(ip,ic), srok(ip,ic,k))
+         else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid clouds
+            cldlay2(ip,ic) = MAX(cldlay2(ip,ic), cldy(ip,ic,k))
+            nsublay2(ip,ic) = MAX(nsublay2(ip,ic), srok(ip,ic,k))
+         else
+            cldlay1(ip,ic) = MAX(cldlay1(ip,ic), cldy(ip,ic,k))
+            nsublay1(ip,ic) = MAX(nsublay1(ip,ic), srok(ip,ic,k))
+         endif
+
+         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,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
+         nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k)
+        enddo
+       enddo
+      enddo
+      cldlay(:,:,1) = cldlay1
+      cldlay(:,:,2) = cldlay2
+      cldlay(:,:,3) = cldlay3
+      nsublay(:,:,1) = nsublay1
+      nsublay(:,:,2) = nsublay2
+      nsublay(:,:,3) = nsublay3
+
+! -- grid-box 3D cloud fraction
+
+      where ( nsub(:,:).gt.0.0 )
+         lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
+      elsewhere
+         lidarcld(:,:) = undef
+      endwhere
+
+! -- layered cloud fractions
+
+      cldlayer = 0.0
+      nsublayer = 0.0
+
+      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
+! ---------------------------------------------------------------
+
+END MODULE MOD_LMD_IPSL_STATS
Index: LMDZ5/branches/testing/libf/phylmd/cosp/load_hydrometeor_classes.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/load_hydrometeor_classes.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/load_hydrometeor_classes.F90	(revision 2298)
@@ -0,0 +1,54 @@
+  subroutine load_hydrometeor_classes(Nprmts_max,dist_prmts_hydro,hp,nhclass)
+  use radar_simulator_types
+  implicit none
+  
+! Purpose:
+!   Loads the hydrometeor classes to be used in calculations
+!   Part of QuickBeam v1.03 by John Haynes
+!   http://reef.atmos.colostate.edu/haynes/radarsim
+!
+! Inputs:  
+!   [dist_prmts_hydro]   from data in hydrometeor class input 
+!
+! Outputs:
+!   [hp]            structure that define hydrometeor types
+!
+! Modified:
+!   08/23/2006  placed into subroutine form (Roger Marchand)
+   
+! ----- INPUT -----
+  integer, intent(in) :: nhclass,Nprmts_max
+  real,dimension(Nprmts_max,nhclass), intent(in) :: dist_prmts_hydro
+! ----- OUTPUTS -----  
+  type(class_param), intent(out) :: hp
+  
+! ----- INTERNAL -----  
+  integer :: i
+	
+    hp%rho(:) = -1
+
+    do i = 1,nhclass,1
+    hp%dtype(i) = dist_prmts_hydro(1,i)
+    hp%col(i) = dist_prmts_hydro(2,i)
+    hp%phase(i) = dist_prmts_hydro(3,i)
+    hp%cp(i) = dist_prmts_hydro(4,i)
+    hp%dmin(i) = dist_prmts_hydro(5,i)
+    hp%dmax(i) = dist_prmts_hydro(6,i)
+    hp%apm(i) = dist_prmts_hydro(7,i)
+    hp%bpm(i) = dist_prmts_hydro(8,i)
+    hp%rho(i) = dist_prmts_hydro(9,i)
+    hp%p1(i) = dist_prmts_hydro(10,i)
+    hp%p2(i) = dist_prmts_hydro(11,i)
+    hp%p3(i) = dist_prmts_hydro(12,i)
+    enddo
+        
+!   // setup scaling arrays
+    hp%fc = -999.
+    hp%scaled = .false.	
+    hp%z_flag = .false.
+    hp%rho_eff = -999.
+    hp%ifc = -9
+    hp%idd = -9
+   
+  
+  end subroutine load_hydrometeor_classes
Index: LMDZ5/branches/testing/libf/phylmd/cosp/load_mie_table.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/load_mie_table.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/load_mie_table.F90	(revision 2298)
@@ -0,0 +1,69 @@
+  subroutine load_mie_table(mie_table_name,mt)
+  use radar_simulator_types
+  implicit none
+  
+! Purpose:
+!   Loads the Mie table data
+!   Part of Quickbeam v1.03
+!   http://reef.atmos.colostate.edu/haynes/radarsim
+!
+! Inputs:  
+!   [mie_table_name]   Mie table input file
+!
+! Outputs:
+!   [mt]            structure of Mie table data
+!
+! Created from Quickbeam v1.02 08/24/2006 by Roger Marchand  
+
+! ----- INPUT -----
+  character*200, intent(in) :: mie_table_name
+
+! ----- OUTPUT -----
+  type(mie), intent(out) :: mt
+
+! ----- INTERNAL -----  
+  integer :: i
+
+  integer*4 :: dummy_in(4)
+	
+    open(51,file=mie_table_name,action='read')
+ 
+    read(51,*) dummy_in 
+
+	if(dummy_in(1).ne. mt_nfreq .or. &
+	   dummy_in(2).ne. mt_ntt .or. &
+	   dummy_in(3).ne. mt_nf .or. &
+	   dummy_in(4).ne. mt_nd) then
+
+		print *,'Mie file is of size :',dummy_in(:)
+		print *,'  expected a size of:',mt_nfreq, mt_ntt,mt_nf,mt_nf
+		print *,'  change paramters in radar_simulator_types.f90 ?? '
+		stop
+	endif
+
+    read(51,*) mt%freq
+    read(51,*) mt%tt
+    read(51,*) mt%f
+    read(51,*) mt%phase
+    read(51,*) mt%D
+    read(51,*) mt%qext
+    read(51,*) mt%qbsca
+    
+    close(51)
+
+! // create arrays of liquid/ice temperature
+  cnt_liq = 0
+  cnt_ice = 0
+  do i=1,mt_ntt
+    if (mt%phase(i) == 0) cnt_liq = cnt_liq + 1
+    if (mt%phase(i) == 1) cnt_ice = cnt_ice + 1
+  enddo
+  allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))
+  do i=1,cnt_liq
+    mt_ttl(i) = mt%tt(i)
+  enddo
+  do i=1,cnt_ice
+    mt_tti(i) = mt%tt(cnt_liq+i)
+  enddo
+
+  end subroutine load_mie_table
Index: LMDZ5/branches/testing/libf/phylmd/cosp/math_lib.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/math_lib.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/math_lib.F90	(revision 2298)
@@ -0,0 +1,395 @@
+! 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: LMDZ5/branches/testing/libf/phylmd/cosp/mrgrnk.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/mrgrnk.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/mrgrnk.F90	(revision 2298)
@@ -0,0 +1,410 @@
+Module m_mrgrnk
+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: LMDZ5/branches/testing/libf/phylmd/cosp/optics_lib.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/optics_lib.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/optics_lib.F90	(revision 2298)
@@ -0,0 +1,747 @@
+! 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, t, n_r, n_i)
+  implicit none
+!  
+! Purpose:
+!   compute complex index of refraction of liquid water
+!
+! Inputs:
+!   [freq]    frequency (GHz)
+!   [t]       temperature (C)
+!
+! 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,t
+  
+! ----- 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
+  complex*16 e_comp, sq
+
+  ld = 100.*2.99792458E8/(freq*1E9)
+  es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 &
+       -2.8E-8*(t-25.)**3))
+  ei = 5.27137+0.021647*t-0.00131198*t**2
+  a = -(16.8129/(t+273.))+0.0609265
+  ls = 0.00033836*exp(2513.98/(t+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 (C)
+!
+! 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,tk,wlmax,wlmin, &
+            x,x1,x2,y,y1,y2,ylo,yhi
+
+  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
+
+! // convert frequency to wavelength (um)
+  alam=3E5/freq
+  if((alam < wlmin) .or. (alam > wlmax)) then
+    print *, 'm_ice: wavelength out of bounds'
+    stop
+  endif
+
+! // convert temperature to K
+  tk = t + 273.16
+
+  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: LMDZ5/branches/testing/libf/phylmd/cosp/pf_to_mr.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/pf_to_mr.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/pf_to_mr.F	(revision 2298)
@@ -0,0 +1,128 @@
+! (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:
+! 
+!     * 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.
+      
+      subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls,
+     &                    rain_cv,snow_cv,prec_frac,
+     &                    p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls,
+     &                    mx_rain_cv,mx_snow_cv)
+
+
+      implicit none
+
+      INTEGER npoints       !  number of model points in the horizontal
+      INTEGER nlev          !  number of model levels in column
+      INTEGER ncol          !  number of subcolumns
+
+      INTEGER i,j,ilev,ibox
+      
+      REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precipitation flux
+      REAL grpl_ls(npoints,nlev)
+      REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precipitation flux
+
+      REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
+                                        ! 1 -> LS precipitation
+                                        ! 2 -> CONV precipitation
+                                        ! 3 -> both
+      REAL mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev)
+      REAL mx_grpl_ls(npoints,ncol,nlev)
+      REAL mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev)
+      REAL p(npoints,nlev),t(npoints,nlev)
+      REAL ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho
+      REAL term1r,term1s,term1g,term2r,term2s,term2g,term3
+      REAL term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv
+      REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g
+      
+      ! method from Khairoutdinov and Randall (2003 JAS)		
+
+      ! --- List of constants from Appendix B
+      ! Constant in fall speed formula
+      ar=842.
+      as=4.84
+      ag=94.5
+      ! Exponent in fall speed formula
+      br=0.8
+      bs=0.25
+      bg=0.5
+      ! Intercept parameter
+      nr=8.*1000.*1000.
+      ns=3.*1000.*1000.
+      ng=4.*1000.*1000.
+      ! Densities for air and hydrometeors
+      rho0=1.29
+      rhor=1000.
+      rhos=100.
+      rhog=400.
+      ! Term 1 of Eq. (A19).
+      term1r=ar*17.8379/6.
+      term1s=as*8.28508/6.
+      term1g=ag*11.6317/6.
+      ! Term 2 of Eq. (A19).
+      term2r=(3.14159265*rhor*nr)**(-br/4.)
+      term2s=(3.14159265*rhos*ns)**(-bs/4.)
+      term2g=(3.14159265*rhog*ng)**(-bg/4.)
+      
+      term1x2r=term1r*term2r
+      term1x2s=term1s*term2s
+      term1x2g=term1g*term2g
+      do ilev=1,nlev
+        do j=1,npoints
+            rho=p(j,ilev)/(287.05*t(j,ilev))
+            term3=(rho0/rho)**0.5
+            ! Term 4 of Eq. (A19).
+            t123r=term1x2r*term3
+            t123s=term1x2s*term3
+            t123g=term1x2g*term3
+            term4r_ls=rain_ls(j,ilev)/(t123r)
+            term4s_ls=snow_ls(j,ilev)/(t123s)
+            term4g_ls=grpl_ls(j,ilev)/(t123g)
+            term4r_cv=rain_cv(j,ilev)/(t123r)
+            term4s_cv=snow_cv(j,ilev)/(t123s)
+            do ibox=1,ncol
+                mx_rain_ls(j,ibox,ilev)=0.
+                mx_snow_ls(j,ibox,ilev)=0.
+                mx_grpl_ls(j,ibox,ilev)=0.
+                mx_rain_cv(j,ibox,ilev)=0.
+                mx_snow_cv(j,ibox,ilev)=0.
+                if ((prec_frac(j,ibox,ilev) .eq. 1.) .or.
+     &              (prec_frac(j,ibox,ilev) .eq. 3.)) then 
+                    mx_rain_ls(j,ibox,ilev)=
+     &                     (term4r_ls**(1./(1.+br/4.)))/rho
+                    mx_snow_ls(j,ibox,ilev)=
+     &                     (term4s_ls**(1./(1.+bs/4.)))/rho
+                    mx_grpl_ls(j,ibox,ilev)=
+     &                     (term4g_ls**(1./(1.+bg/4.)))/rho
+                endif
+                if ((prec_frac(j,ibox,ilev) .eq. 2.) .or.
+     &              (prec_frac(j,ibox,ilev) .eq. 3.)) then 
+                    mx_rain_cv(j,ibox,ilev)=
+     &                     (term4r_cv**(1./(1.+br/4.)))/rho
+                    mx_snow_cv(j,ibox,ilev)=
+     &                     (term4s_cv**(1./(1.+bs/4.)))/rho
+                endif
+            enddo ! loop over ncol
+        enddo ! loop over npoints
+      enddo ! loop over nlev
+  
+      end
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90	(revision 2298)
@@ -0,0 +1,381 @@
+! Simulateur COSP : Cfmip Observation Simulator Package
+
+! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS
+!Idelkadi Abderrahmane Aout-Septembre 2009
+
+  subroutine phys_cosp( itap,dtime,freq_cosp, &
+                        ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
+                        ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, &
+                        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
+! overlap,                              !Overlap type in SCOPS
+! 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 microm)
+! 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 relatif
+! 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 :
+! calipso2D,                            !Lidar Low/heigh/Mean/Total-level Cloud Fraction
+! calipso3D,                            !Lidar Cloud Fraction (532 nm)
+! cfadlidar,                            !Lidar Scattering Ratio CFAD (532 nm)
+! parasolrefl,                          !PARASOL-like mono-directional reflectance
+! atb,                                  !Lidar Attenuated Total Backscatter (532 nm)
+! betamol,                              !Lidar Molecular Backscatter (532 nm)
+! cfaddbze,                             !Radar Reflectivity Factor CFAD (94 GHz)
+! clcalipso2,                           !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat
+! dbze,                                 !Efective_reflectivity_factor
+! cltlidarradar,                        !Lidar and Radar Total Cloud Fraction
+! clMISR,                               !Cloud Fraction as Calculated by the MISR Simulator
+! clisccp2,                             !Cloud Fraction as Calculated by the ISCCP Simulator
+! boxtauisccp,                          !Optical Depth in Each Column as Calculated by the ISCCP Simulator
+! boxptopisccp,                         !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator
+! tclisccp,                             !Total Cloud Fraction as Calculated by the ISCCP Simulator
+! ctpisccp,                             !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator
+! tauisccp,                             !Mean Optical Depth as Calculated by the ISCCP Simulator
+! albisccp,                             !Mean Cloud Albedo as Calculated by the ISCCP Simulator
+! meantbisccp,                          !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
+! meantbclrisccp                        !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE MOD_COSP
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  use ioipsl
+  use iophy
+  use cosp_output_mod
+  use cosp_output_write_mod
+ 
+  IMPLICIT NONE
+
+  ! Local variables
+  character(len=64),PARAMETER  :: cosp_input_nl='cosp_input_nl.txt'
+  character(len=64),PARAMETER  :: cosp_output_nl='cosp_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 levels
+  Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F
+  integer, save :: Nlr          ! Number of levels in statistical outputs
+  integer, save :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
+  integer :: i
+  type(cosp_config),save :: cfg   ! Configuration options
+!$OMP THREADPRIVATE(cfg)
+  type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP
+  type(cosp_subgrid) :: sgx     ! Subgrid outputs
+  type(cosp_sgradar) :: sgradar ! Output from radar simulator
+  type(cosp_sglidar) :: sglidar ! Output from lidar simulator
+  type(cosp_isccp)   :: isccp   ! Output from ISCCP simulator
+  type(cosp_misr)    :: misr    ! Output from MISR simulator
+  type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
+  type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator
+  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
+
+  integer :: t0,t1,count_rate,count_max
+  integer :: Nlon,Nlat,geomode
+  real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw
+!$OMP THREADPRIVATE(emsfc_lw)
+  integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels
+  real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem
+  integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay
+  integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type
+  integer, save :: platform,satellite,Instrument,Nchannels
+  logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff
+
+! Declaration necessaires pour les sorties IOIPSL
+  integer :: ii
+  real    :: ecrit_day,ecrit_hf,ecrit_mth
+  logical :: ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, ok_all_xml
+
+  logical, save :: debut_cosp=.true.
+!$OMP THREADPRIVATE(debut_cosp)
+
+  include "dimensions.h"
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM
+  integer                         :: overlaplmdz   !  overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz)
+  real,dimension(Nptslmdz,Nlevlmdz) :: height,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,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(Nlevlmdz)        :: presnivs
+  integer                         :: itap,k,ip
+  real                            :: dtime,freq_cosp
+  
+!
+   namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, &
+              npoints_it,ncolumns,use_vgrid,nlr,csat_vgrid, &
+              radar_freq,surface_radar,use_mie_tables, &
+              use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, &
+              lidar_ice_type,use_precipitation_fluxes,use_reff, &
+              platform,satellite,Instrument,Nchannels, &
+              Channels,Surfem,ZenAng,co2,ch4,n2o,co
+
+!---------------- End of declaration of variables --------------
+   
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Read namelist with COSP inputs
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ if (debut_cosp) then
+  NPoints=Nptslmdz
+  Nlevels=Nlevlmdz
+  
+! Lecture du namelist input 
+  CALL read_cosp_input
+
+! Clefs Outputs 
+  call read_cosp_output_nl(cosp_output_nl,cfg)
+
+    if (overlaplmdz.ne.overlap) then
+       print*,'Attention overlaplmdz different de overlap lu dans namelist '
+    endif
+   print*,'Fin lecture Namelists, debut_cosp =',debut_cosp
+
+  print*,' Cles des differents simulateurs cosp :'
+  print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
+          cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim
+
+  endif ! debut_cosp
+
+!  print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', &
+!          itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Allocate memory for gridbox type
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Allocating memory for gridbox type...'
+
+        call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
+                                    lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
+                                    use_precipitation_fluxes,use_reff, &
+                                    Platform,Satellite,Instrument,Nchannels,ZenAng, &
+                                    channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx)
+        
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Here code to populate input structure
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+        print *, 'Populating input structure...'
+        gbx%longitude = lon
+        gbx%latitude = lat
+
+        gbx%p = p !
+        gbx%ph = ph
+        gbx%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
+        gbx%zlev_half = zlev_half
+
+        gbx%T = T
+        gbx%q = rh*100.
+        gbx%sh = sh
+! On ne veut pas que cosp distingue les nuages stratiformes et convectifs
+! on passe les contenus totaux (conv+strat)
+        gbx%cca = 0. !convective_cloud_amount (1)
+        gbx%tca = tca ! total_cloud_amount (1)
+        gbx%psfc = ph(:,1) !pression de surface
+        gbx%skt  = skt !Skin temperature (K)
+
+        do ip = 1, Npoints
+          if (fracTerLic(ip).ge.0.5) then
+             gbx%land(ip) = 1.
+          else
+             gbx%land(ip) = 0.
+          endif
+        enddo
+        gbx%mr_ozone  = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg)
+! A voir l equivalent LMDZ (u10m et v10m)
+        gbx%u_wind  = u_wind !eastward_wind (m s-1)
+        gbx%v_wind  = v_wind !northward_wind
+
+! sunlit calcule a partir de la fraction d ensoleillement par jour
+      do ip = 1, Npoints
+        if (sunlit(ip).le.0.) then
+           gbx%sunlit(ip)=0.
+        else
+           gbx%sunlit(ip)=1.
+        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
+
+     gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6
+     gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6
+     gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6
+     gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6
+
+        ! ISCCP simulator
+        gbx%dtau_s   = dtau_s
+        gbx%dtau_c   = 0.
+        gbx%dem_s    = dem_s
+        gbx%dem_c    = 0.
+
+! Surafce emissivity
+       emsfc_lw = 1.
+               
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Define new vertical grid
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Defining new vertical grid...'
+        call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid)
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+       ! Allocate memory for other types
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Allocating memory for other types...'
+        call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx)
+        call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar)
+        call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar)
+        call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar)
+        call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar)
+        call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp)
+        call construct_cosp_misr(cfg,Npoints,misr)
+
+!+++++++++++++ Open output files and define output files axis !+++++++++++++
+     if (debut_cosp) then
+
+      !$OMP MASTER
+        print *, ' Open outpts files and define axis'
+        call 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, vgrid)
+      !$OMP END MASTER
+      !$OMP BARRIER
+        debut_cosp=.false.
+      endif ! debut_cosp
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Call simulator
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Calling simulator...'
+        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!!
+       print *, 'Calling write output'
+        call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
+                               cfg, gbx, vgrid, sglidar, stlidar, isccp)
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Deallocate memory in derived types
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Deallocating memory...'
+        call free_cosp_gridbox(gbx)
+        call free_cosp_subgrid(sgx)
+        call free_cosp_sgradar(sgradar)
+        call free_cosp_radarstats(stradar)
+        call free_cosp_sglidar(sglidar)
+        call free_cosp_lidarstats(stlidar)
+        call free_cosp_isccp(isccp)
+        call free_cosp_misr(misr)
+        call free_cosp_vgrid(vgrid)  
+  
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! Time in s. Only for testing purposes
+!  call system_clock(t1,count_rate,count_max)
+!  print *,(t1-t0)*1.0/count_rate
+ 
+  CONTAINS 
+  
+  SUBROUTINE read_cosp_input
+    
+    IF (is_master) THEN
+      OPEN(10,file=cosp_input_nl,status='old')
+      READ(10,nml=cosp_input)
+      CLOSE(10)
+    ENDIF
+    CALL bcast(overlap)
+    CALL bcast(isccp_topheight)
+    CALL bcast(isccp_topheight_direction)
+    CALL bcast(npoints_it)
+    CALL bcast(ncolumns)
+    CALL bcast(use_vgrid)
+    CALL bcast(nlr)
+    CALL bcast(csat_vgrid)
+    CALL bcast(radar_freq)
+    CALL bcast(surface_radar)
+    CALL bcast(use_mie_tables)
+    CALL bcast(use_gas_abs)
+    CALL bcast(do_ray)
+    CALL bcast(melt_lay)
+    CALL bcast(k2)
+    CALL bcast(Nprmts_max_hydro)
+    CALL bcast(Naero)
+    CALL bcast(Nprmts_max_aero)
+    CALL bcast(lidar_ice_type)
+    CALL bcast(use_precipitation_fluxes)
+    CALL bcast(use_reff)
+    CALL bcast(platform)
+    CALL bcast(satellite)
+    CALL bcast(Instrument)
+    CALL bcast(Nchannels)
+    CALL bcast(Channels)
+    CALL bcast(Surfem)
+    CALL bcast(ZenAng)
+    CALL bcast(co2)
+    CALL bcast(ch4)
+    CALL bcast(n2o)
+    CALL bcast(co)
+!$OMP BARRIER  
+  END SUBROUTINE read_cosp_input 
+
+end subroutine phys_cosp
Index: LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90.prev
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90.prev	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90.prev	(revision 2298)
@@ -0,0 +1,456 @@
+! Simulateur COSP : Cfmip Observation Simulator Package
+! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS
+!Idelkadi Abderrahmane Aout-Septembre 2009
+
+  subroutine phys_cosp( itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf, &
+                        overlaplmdz,Nptslmdz,Nlevlmdz,lon,lat, presnivs, &
+                        ref_liq,ref_ice,fracTerLic,u_wind,v_wind,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
+! overlap,                              !Overlap type in SCOPS
+! 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 microm)
+! fracTerLic,                               !Fraction terre a convertir en masque
+! u_wind,v_wind,                        !Vents a 10m ???
+! phi,                                  !Geopotentiel
+! 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 relatif
+! 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 :
+! calipso2D,                            !Lidar Low/heigh/Mean/Total-level Cloud Fraction
+! calipso3D,                            !Lidar Cloud Fraction (532 nm)
+! cfadlidar,                            !Lidar Scattering Ratio CFAD (532 nm)
+! parasolrefl,                          !PARASOL-like mono-directional reflectance
+! atb,                                  !Lidar Attenuated Total Backscatter (532 nm)
+! betamol,                              !Lidar Molecular Backscatter (532 nm)
+! cfaddbze,                             !Radar Reflectivity Factor CFAD (94 GHz)
+! clcalipso2,                           !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat
+! dbze,                                 !Efective_reflectivity_factor
+! cltlidarradar,                        !Lidar and Radar Total Cloud Fraction
+! clMISR,                               !Cloud Fraction as Calculated by the MISR Simulator
+! clisccp2,                             !Cloud Fraction as Calculated by the ISCCP Simulator
+! boxtauisccp,                          !Optical Depth in Each Column as Calculated by the ISCCP Simulator
+! boxptopisccp,                         !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator
+! tclisccp,                             !Total Cloud Fraction as Calculated by the ISCCP Simulator
+! ctpisccp,                             !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator
+! tauisccp,                             !Mean Optical Depth as Calculated by the ISCCP Simulator
+! albisccp,                             !Mean Cloud Albedo as Calculated by the ISCCP Simulator
+! meantbisccp,                          !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
+! meantbclrisccp                        !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE MOD_COSP
+  USE mod_phys_lmdz_para
+  use ioipsl
+  use iophy
+ 
+  IMPLICIT NONE
+
+  ! Local variables
+  character(len=64)  :: cosp_input_nl='cosp_input_nl.txt'
+  character(len=64)  :: cosp_output_nl='cosp_output_nl.txt'
+  character(len=512), save :: finput ! Input file name
+  character(len=512), save :: cmor_nl
+  integer, save :: isccp_topheight,isccp_topheight_direction,overlap
+  integer,save  :: Ncolumns     ! Number of subcolumns in SCOPS
+  integer,parameter :: Ncollmdz=20
+  integer, save :: Npoints      ! Number of gridpoints
+  integer, save :: Nlevels      ! Number of levels
+  Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F
+  integer, save :: Nlr          ! Number of levels in statistical outputs
+  integer, save :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
+  integer :: i
+  type(cosp_config),save :: cfg   ! Configuration options
+  type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP
+  type(cosp_subgrid) :: sgx     ! Subgrid outputs
+  type(cosp_sgradar) :: sgradar ! Output from radar simulator
+  type(cosp_sglidar) :: sglidar ! Output from lidar simulator
+  type(cosp_isccp)   :: isccp   ! Output from ISCCP simulator
+  type(cosp_misr)    :: misr    ! Output from MISR simulator
+  type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
+  type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator
+  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
+
+  integer :: t0,t1,count_rate,count_max
+  integer :: Nlon,Nlat,geomode
+  real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw
+  integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels
+  real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem
+  integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay
+  integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type
+  integer, save :: platform,satellite,Instrument,Nchannels
+  logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff
+
+! Declaration necessaires pour les sorties IOIPSL
+  integer :: ii,idayref
+  real    :: zjulian,zstoday,zstomth,zstohf,zout,ecrit_day,ecrit_hf,ecrit_mth
+  integer :: nhori,nvert,nvertp,nvertisccp,nvertm,nvertcol
+  integer, save :: nid_day_cosp,nid_mth_cosp,nid_hf_cosp
+  logical, save :: debut_cosp=.true.
+  integer :: itau_wcosp
+  character(len=10),dimension(Ncollmdz) :: chcol=(/'c01','c02','c03','c04','c05','c06','c07','c08','c09','c10', &
+                                                   'c11','c12','c13','c14','c15','c16','c17','c18','c19','c20'/)
+  real,dimension(Ncollmdz) :: column_ax
+  integer, save :: Nlevout
+
+  include "dimensions.h"
+  include "temps.h"  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM
+  integer                         :: overlaplmdz   !  overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz)
+!  real,dimension(Npoints,Nlevels) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, &
+  real,dimension(Nptslmdz,Nlevlmdz) :: height,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,mr_ozone,radliq,radice,dtau_s,dem_s
+  real,dimension(Nptslmdz,Nlevlmdz) ::  fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI
+  real,dimension(Nptslmdz)        :: lon,lat,skt,fracTerLic,u_wind,v_wind
+  real,dimension(Nlevlmdz)        :: presnivs
+  real                            :: ref_liq,ref_ice 
+  integer                         :: itap,k,ip
+  real                            :: dtime,freq_cosp
+
+!
+   namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight,isccp_topheight_direction, &
+              npoints,npoints_it,ncolumns,nlevels,use_vgrid,nlr,csat_vgrid,finput, &
+              radar_freq,surface_radar,use_mie_tables, &
+              use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, &
+              lidar_ice_type,use_precipitation_fluxes,use_reff, &
+              platform,satellite,Instrument,Nchannels, &
+              Channels,Surfem,ZenAng,co2,ch4,n2o,co
+
+!---------------- End of declaration of variables --------------
+   
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Read namelist with COSP inputs
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ if (debut_cosp) then
+! Lecture du namelist input 
+  open(10,file=cosp_input_nl,status='old')
+  read(10,nml=cosp_input)
+  close(10)
+! Clefs Outputs 
+  call read_cosp_output_nl(cosp_output_nl,cfg)
+
+    if ( (Ncollmdz.ne.Ncolumns).or.(Nptslmdz.ne.Npoints).or.(Nlevlmdz.ne.Nlevels) ) then
+       print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F = ', &
+               Nptslmdz, Nlevlmdz, Ncollmdz
+       print*,'Nb points Horiz, Vert, Sub-col lus dans namelist = ', &
+               Npoints, Nlevels, Ncolumns
+       print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F est different de celui lu par namelist '
+       call abort
+    endif
+
+    if (overlaplmdz.ne.overlap) then
+       print*,'Attention overlaplmdz different de overlap lu dans namelist '
+    endif
+   print*,'Fin lecture Namelists, debut_cosp =',debut_cosp
+
+  endif ! debut_cosp
+
+  print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', &
+          itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Allocate local arrays
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!        call system_clock(t0,count_rate,count_max) !!! Only for testing purposes
+        
+        
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Allocate memory for gridbox type
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Allocating memory for gridbox type...'
+        print*,'Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro ',Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro 
+  print*,' Cles sorties cosp :'
+  print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
+          cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim
+        call construct_cosp_gridbox(float(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
+                                    lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
+                                    use_precipitation_fluxes,use_reff, &
+                                    Platform,Satellite,Instrument,Nchannels,ZenAng, &
+                                    channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx)
+        
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Here code to populate input structure
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+        print *, 'Populating input structure...'
+        gbx%longitude = lon
+        gbx%latitude = lat
+
+        gbx%p = p !
+        gbx%ph = ph
+        gbx%zlev_half = phi/9.81
+
+       do k = 1, Nlevels-1
+       do ip = 1, Npoints
+        zlev(ip,k) = phi(ip,k)/9.81 + (phi(ip,k+1)-phi(ip,k))/9.81 * (ph(ip,k)-ph(ip,k+1))/p(ip,k)
+       enddo
+       enddo
+       do ip = 1, Npoints
+        zlev(ip,Nlevels) = zlev(ip,Nlevels-1)+ 2.*(phi(ip,Nlevels)/9.81-zlev(ip,Nlevels-1))
+       END DO
+        gbx%zlev = zlev
+
+        gbx%T = T
+        gbx%q = rh*100.
+        gbx%sh = sh
+        gbx%cca = cca !convective_cloud_amount (1)
+        gbx%tca = tca ! total_cloud_amount (1)
+        gbx%psfc = ph(:,1) !pression de surface
+        gbx%skt  = skt !Skin temperature (K)
+
+        do ip = 1, Npoints
+          if (fracTerLic(ip).ge.0.5) then
+             gbx%land(ip) = 1.
+          else
+             gbx%land(ip) = 0.
+          endif
+        enddo
+        gbx%mr_ozone  = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg)
+! A voir l equivalent LMDZ (u10m et v10m)
+        gbx%u_wind  = u_wind !eastward_wind (m s-1)
+        gbx%v_wind  = v_wind !northward_wind
+! Attention
+        gbx%sunlit  = 1
+
+! 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
+
+!Attention Teste
+       do k = 1, Nlevels
+        do ip = 1, Npoints
+!     liquid particles :
+         radliq(ip,k) = 12.0e-06
+         if (k.le.3) radliq(ip,k) = 11.0e-06
+
+!    ice particles :
+        if ( (t(ip,k)-273.15).gt.-81.4 ) then
+          radice(ip,k) = (0.71*(t(ip,k)-273.15)+61.29)*1e-6
+        else
+          radice(ip,k) = 3.5*1e-6
+        endif
+       END DO
+      END DO
+      gbx%Reff(:,:,I_LSCLIQ) = radliq
+      gbx%Reff(:,:,I_LSCICE) = radice
+      gbx%Reff(:,:,I_CVCLIQ) = radliq
+      gbx%Reff(:,:,I_CVCICE) = radice
+
+        ! ISCCP simulator
+        gbx%dtau_s   = dtau_s
+        print*,'dtau_s(1,:)=',gbx%dtau_s(1,:)
+        gbx%dtau_c   = 0.
+        gbx%dem_s    = dem_s
+        print*,'dem_s(1,:)=',gbx%dem_s(1,:)
+        gbx%dem_c    = 0.
+
+! Surafce emissivity
+       emsfc_lw = 1.
+               
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Define new vertical grid
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Defining new vertical grid...'
+        call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid)
+
+ if (debut_cosp) then
+! Creer le fichier de sorie, definir les variable de sortie
+  ! Axe verticale (Pa ou Km)
+     Nlevout = vgrid%Nlvgrid
+   
+        do ii=1,Ncolumns
+          column_ax(ii) = float(ii)
+        enddo
+
+     include "ini_histmthCOSP.h"
+     include "ini_histdayCOSP.h"
+     include "ini_histhfCOSP.h"
+
+   print*,'Fin Initialisation des sorties COSP, debut_cosp =',debut_cosp 
+   print*,'R_UNDEF=',R_UNDEF
+
+   debut_cosp=.false.
+  endif ! debut_cosp
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+       ! Allocate memory for other types
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Allocating memory for other types...'
+        call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx)
+        call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar)
+        call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar)
+        call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar)
+        call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar)
+        call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp)
+        call construct_cosp_misr(cfg,Npoints,misr)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Call simulator
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Calling simulator...'
+        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+         print*,'stlidar%lidarcld(1,:)=',stlidar%lidarcld(1,:)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Write outputs to CMOR-compliant NetCDF
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! A traiter le cas ou l on a des valeurs indefinies
+! Attention teste
+
+! if(1.eq.0)then
+
+
+   do k = 1,Nlevout
+!     do ip = 1,Npoints
+!     if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then
+!      stlidar%lidarcld(ip,k)=0.
+!     endif
+!     enddo
+
+
+     do ii= 1,SR_BINS
+      do ip = 1,Npoints
+       if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then
+        stlidar%cfad_sr(ip,ii,k)=0.
+       endif
+      enddo
+     enddo
+   enddo   
+   
+  do ip = 1,Npoints
+   do k = 1,Nlevlmdz 
+     if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then
+      sglidar%beta_mol(ip,k)=0.
+     endif
+    
+     do ii= 1,Ncolumns
+       if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then
+        sglidar%beta_tot(ip,ii,k)=0.
+       endif  
+     enddo
+
+    enddo    !k = 1,Nlevlmdz
+   enddo     !ip = 1,Npoints
+
+   do k = 1,LIDAR_NCAT
+    do ip = 1,Npoints
+     if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then
+      stlidar%cldlayer(ip,k)=0.
+     endif
+    enddo
+   enddo
+
+! endif 
+
+   do ip = 1,Npoints
+    if(isccp%totalcldarea(ip).eq.-1.E+30)then
+      isccp%totalcldarea(ip)=0.
+    endif
+    if(isccp%meanptop(ip).eq.-1.E+30)then
+      isccp%meanptop(ip)=0.
+    endif
+    if(isccp%meantaucld(ip).eq.-1.E+30)then
+      isccp%meantaucld(ip)=0.
+    endif
+    if(isccp%meanalbedocld(ip).eq.-1.E+30)then
+      isccp%meanalbedocld(ip)=0.
+    endif
+    if(isccp%meantb(ip).eq.-1.E+30)then
+      isccp%meantb(ip)=0.
+    endif
+    if(isccp%meantbclr(ip).eq.-1.E+30)then
+      isccp%meantbclr(ip)=0.
+    endif
+
+    do k=1,7
+     do ii=1,7
+     if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then
+      isccp%fq_isccp(ip,ii,k)=0.
+     endif
+     enddo
+    enddo
+
+    do ii=1,Ncolumns
+     if(isccp%boxtau(ip,ii).eq.-1.E+30)then
+       isccp%boxtau(ip,ii)=0.
+     endif
+    enddo
+
+    do ii=1,Ncolumns
+     if(isccp%boxptop(ip,ii).eq.-1.E+30)then
+       isccp%boxptop(ip,ii)=0.
+     endif
+    enddo
+   enddo
+
+  include "write_histmthCOSP.h"
+  include "write_histdayCOSP.h"
+  include "write_histhfCOSP.h"
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! Deallocate memory in derived types
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        print *, 'Deallocating memory...'
+        call free_cosp_gridbox(gbx)
+        call free_cosp_subgrid(sgx)
+        call free_cosp_sgradar(sgradar)
+        call free_cosp_radarstats(stradar)
+        call free_cosp_sglidar(sglidar)
+        call free_cosp_lidarstats(stlidar)
+        call free_cosp_isccp(isccp)
+        call free_cosp_misr(misr)
+        call free_cosp_vgrid(vgrid)  
+  
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! Time in s. Only for testing purposes
+!  call system_clock(t1,count_rate,count_max)
+!  print *,(t1-t0)*1.0/count_rate
+    
+end subroutine phys_cosp
Index: LMDZ5/branches/testing/libf/phylmd/cosp/prec_scops.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/prec_scops.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/prec_scops.F	(revision 2298)
@@ -0,0 +1,268 @@
+! (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:
+! 
+!     * 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.
+      
+      subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate,
+     &                      frac_out,prec_frac)
+
+
+      implicit none
+
+      INTEGER npoints       !  number of model points in the horizontal
+      INTEGER nlev          !  number of model levels in column
+      INTEGER ncol          !  number of subcolumns
+
+      INTEGER i,j,ilev,ibox,cv_col
+      
+      REAL ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev)
+
+      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
+                              !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      REAL 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 = 0.05*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
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator.F90	(revision 2298)
@@ -0,0 +1,511 @@
+  subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
+    nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_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_out)
+
+!     rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe)
+ 
+  use m_mrgrnk 
+  use array_lib
+  use math_lib
+  use optics_lib
+  use radar_simulator_types
+  implicit none
+  
+! Purpose:
+!   Simulates a vertical profile of radar reflectivity
+!   Part of QuickBeam v1.04 by John Haynes & Roger Marchand
+!
+! Inputs:
+!   [freq]            radar frequency (GHz), can be anything unless
+!                     use_mie_table=1, in which case one of 94,35,13.8,9.6,3
+!   [k2]              |K|^2, the dielectric constant, set to -1 to use the
+!                     frequency dependent default
+!   [do_ray]          1=do Rayleigh calcs, 0=not
+!   [use_gas_abs]     1=do gaseous abs calcs, 0=not,
+!                     2=use same as first profile (undocumented)
+!   [use_mie_table]   1=use Mie tables, 0=not
+!   [mt]              Mie look up table
+!   [nhclass]         number of hydrometeor types
+!   [hp]              structure that defines hydrometeor types
+!   [nprof]           number of hydrometeor profiles
+!   [ngate]           number of vertical layers
+!   [nsizes]          number of discrete particles in [D]
+!   [D]               array of discrete particles (um)
+!
+!   (The following 5 arrays must be in order from closest to the radar
+!    to farthest...)
+!   [hgt_matrix]      height of hydrometeors (km)
+!   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
+!   [re_matrix]       OPTIONAL table of hydrometeor effective radii (microns)
+!   [p_matrix]        pressure profile (hPa)
+!   [t_matrix]        temperature profile (C)
+!   [rh_matrix]       relative humidity profile (%)
+!
+! 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, scaling factors (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)
+
+! ----- INPUTS -----  
+  type(mie), intent(in) :: mt
+  type(class_param), intent(inout) :: hp
+  real*8, intent(in) :: freq,k2
+  integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
+    nhclass,nprof,ngate,nsizes
+  real*8, dimension(nsizes), intent(in) :: D
+  real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
+    t_matrix,rh_matrix
+  real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
+  real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
+    
+! ----- OUTPUTS -----
+  real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
+ 	g_atten_to_vol,dBZe,h_atten_to_vol
+
+! ----- OPTIONAL -----
+  real*8, optional, dimension(ngate,nprof) :: &
+  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 -----
+  integer :: &
+  phase, &			! 0=liquid, 1=ice
+  ns 				! number of discrete drop sizes
+
+  integer*4, dimension(ngate) :: &
+  hydro				! 1=hydrometeor in vol, 0=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, Ntemp, &    		! discrete concentrations (cm^-3 um^-1)
+  rhoi				! discrete densities (kg m^-3)
+  
+  real*8, dimension(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)
+  a_to_vol, &			! integrated atten due to hydometeors, r>v (dB)
+  g_to_vol			! integrated atten due to gases, r>v (dB)
+   
+ 
+  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
+  integer*4 :: tp, i, j, k, pr, itt, iff
+
+  real*8 bin_length,step,base,step_list(25),base_list(25)
+  integer*4 iRe_type,n,max_bin
+  
+  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)
+  
+    ! set up Re bins for z_scalling
+	bin_length=50;
+	max_bin=25
+
+	step_list(1)=1
+	base_list(1)=75 
+	do j=2,max_bin
+		step_list(j)=3*(j-1);
+		if(step_list(j)>bin_length) then
+			step_list(j)=bin_length;
+		endif
+		base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1));
+	enddo
+
+
+  pi = acos(-1.0)
+  if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1)
+
+	
+  ! // loop over each profile (nprof)
+  do pr=1,nprof
+
+!   ----- calculations for each volume ----- 
+    z_vol(:) = 0
+    z_ray(:) = 0
+    kr_vol(:) = 0
+    hydro(:) = 0    
+
+!   // loop over eacho range gate (ngate)
+    do k=1,ngate
+  
+!     :: determine if hydrometeor(s) present in volume
+      hydro(k) = 0
+      do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S)
+        if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
+          hydro(k) = 1
+          exit
+        endif
+      enddo
+
+      if (hydro(k) == 1) then
+!     :: if there is hydrometeor in the volume            
+
+        rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15))
+
+!       :: loop over hydrometeor type
+        do tp=1,nhclass
+
+          if (hm_matrix(tp,pr,k) <= 1E-12) cycle
+
+	  phase = hp%phase(tp)
+	  if(phase==0) then
+		itt = infind(mt_ttl,t_matrix(pr,k))
+  	  else
+		itt = infind(mt_tti,t_matrix(pr,k))
+      endif
+
+	  ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle
+	  if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8)  then
+
+		apm=hp%apm(tp)
+		bpm=hp%bpm(tp)
+
+  		if ((hp%rho(tp) > 0) .and. (apm < 0)) then
+    			apm = (pi/6)*hp%rho(tp)
+    			bpm = 3.
+  		endif
+
+		tmp1 = 1./(1.+bpm)
+		ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1
+		
+		Re = 1.5E6/ld 
+		
+		re_matrix(tp,pr,k) = Re;
+
+	  endif
+  
+	  if(re_matrix(tp,pr,k).eq.0) then
+
+		iRe_type=1
+		Re=0
+	  else
+		iRe_type=1
+		Re=re_matrix(tp,pr,k)
+		
+		n=floor(Re/bin_length)
+		if(n==0) then
+			if(Re<25) then
+				step=0.5
+				base=0
+			else			
+				step=1
+				base=25
+			endif
+		else
+			if(n>max_bin) then
+				n=max_bin	
+			endif
+
+			step=step_list(n)
+			base=base_list(n)
+		endif
+
+		iRe_type=floor(Re/step)
+
+		if(iRe_type.lt.1) then  
+			iRe_type=1			
+		endif
+
+		Re=step*(iRe_type+0.5)
+		iRe_type=iRe_type+base-floor(n*bin_length/step)
+
+	 	! make sure iRe_type is within bounds
+		if(iRe_type.ge.nRe_types) then  
+
+			! print *, tp, re_matrix(tp,pr,k), Re, iRe_type
+
+			! no scaling allowed
+			Re=re_matrix(tp,pr,k)
+
+			iRe_type=nRe_types
+			hp%z_flag(tp,itt,iRe_type)=.false.
+			hp%scaled(tp,iRe_type)=.false.			
+		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_flag(tp,itt,iRe_type) )  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))
+	    if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))
+	    Di = hp%p1(tp)
+	    Ni = 0.
+	  case default
+ 	    ns = nsizes            
+	    allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+	    if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))	    
+ 	    Di = D
+ 	    Ni = 0.
+	  end select
+
+!         :: create a DSD (using scaling factor if applicable)
+	  ! hp%scaled(tp,iRe_type)=.false.   ! turn off N scaling
+
+	  call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, &
+	    t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+	    hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), &
+	    hp%scaled(tp,iRe_type))
+
+!         :: calculate particle density 
+          ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then
+	  if (phase == 1) then
+	    if (hp%rho(tp) < 0) then
+                
+		! 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
+
+		! alternative is to 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 		! Di now really Deq in microns.
+		
+            else
+
+            	! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
+	     	
+		! 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))  
+
+	    endif
+
+		! if using equivalent volume spheres
+		if (use_mie_table == 1) then
+
+			Ntemp=Ni
+
+			! Find N(Di) from N(Deq) which we know
+			do i=1,ns
+                     		j=infind(Deq,Di(i))
+				Ni(i)=Ntemp(j)
+	        	enddo
+		else
+			! just use Deq and D variable input to mie code
+			Di=Deq;
+		endif
+
+	  endif
+	  rhoi = hp%rho_eff(tp,1:ns,iRe_type)
+	  
+!         :: calculate effective reflectivity factor of volume
+	  if (use_mie_table == 1) then
+	  
+	    if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then
+              hp%idd(tp) = infind(mt%D,Di(1))
+	    endif
+	    
+	    if (phase == 0) then
+	    
+	      ! itt = infind(mt_ttl,t_matrix(pr,k))
+              select case(hp%dtype(tp))
+	      case(4)
+		mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff)
+	        mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff)
+              case default
+  	        mt_qext = mt%qext(:,itt,1,iff)
+	        mt_qbsca = mt%qbsca(:,itt,1,iff)
+	      end select
+
+          call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, &
+	        ze,zr,kr,mt_qext,mt_qbsca,xx)
+	    
+	    else
+
+	      ! itt = infind(mt_tti,t_matrix(pr,k))
+	      select case(hp%dtype(tp))
+	      case(4)
+                if (hp%ifc(tp,1,iRe_type) < 0) then
+                  hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.)
+ 	        endif	   	      
+                mt_qext(1) = &
+		  mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)
+	        mt_qbsca(1) = &
+		  mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)	      
+	      case default
+ 	        do i=1,ns
+ 	          if (hp%ifc(tp,i,iRe_type) < 0) then
+                    hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.)
+ 	          endif	      
+       	          mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
+		  mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
+	        enddo
+	      end select
+
+		   call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, &
+	        ze,zr,kr,mt_qext,mt_qbsca,xx)
+
+	    endif
+
+	  else
+       
+	    xxa = -9.9
+	    call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
+	      ze,zr,kr,xxa,xxa,rhoi)
+
+	      
+	  endif  ! end of use mie table 
+
+		! xxa = -9.9
+	    	!call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
+	      	!	ze2,zr,kr2,xxa,xxa,rhoi)
+
+		! if(abs(ze2-ze)/ze2 > 0.1) then
+  		! if(abs(kr2-kr)/kr2 > 0.1) then
+  		
+		! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff
+		! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2
+		! stop
+
+		!endif
+
+	  deallocate(Di,Ni,rhoi,xxa,Deq)
+  	  if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp)
+
+	  else ! can use z scaling
+	  
+		if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 )  then
+		 
+			ze = hp%Ze_scaled(tp,itt,iRe_type)
+			zr = hp%Zr_scaled(tp,itt,iRe_type)
+			kr = hp%kr_scaled(tp,itt,iRe_type)
+
+		else
+	    		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
+
+	  endif  ! end z_scaling
+ 
+	  ! kr=0 
+
+	  kr_vol(k) = kr_vol(k) + kr
+	  z_vol(k) = z_vol(k) + ze
+	  z_ray(k) = z_ray(k) + zr
+	
+	  ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
+	  if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then
+
+		if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or.  hp%dtype(tp)==2)  .and. abs(hp%p1(tp)+1) < 1E-8  ) .or. &
+		    (  hp%dtype(tp)==3 .or. hp%dtype(tp)==4 )  &
+		) 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_flag(tp,itt,iRe_type)=.True.
+
+		elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then 
+		 
+			hp%Ze_scaled(tp,itt,iRe_type) = ze
+			hp%Zr_scaled(tp,itt,iRe_type) = zr
+			hp%kr_scaled(tp,itt,iRe_type) = kr
+
+			hp%z_flag(tp,itt,iRe_type)=.True.
+		endif
+
+	  endif
+
+        enddo	! end loop of tp (hydrometeor type)
+
+      else
+!     :: volume is hydrometeor-free
+	
+        kr_vol(k) = 0
+	z_vol(k) = -999
+        z_ray(k) = -999
+	
+      endif
+
+!     :: attenuation due to hydrometeors between radar and volume
+      a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1)
+      
+!     :: attenuation due to gaseous absorption between radar and volume
+      if (g_to_vol_in_present) then
+        g_to_vol(k) = g_to_vol_in(k,pr)
+      else
+        if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) )  then
+            g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, &
+            rh_matrix(pr,k),freq)
+            g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1)
+        elseif (use_gas_abs == 0) then
+            g_to_vol(k) = 0
+        endif  
+      endif
+    
+!      kr_matrix(pr,:)=kr_vol
+
+!     :: store results in matrix for return to calling program
+      h_atten_to_vol(pr,k)=a_to_vol(k)
+      g_atten_to_vol(pr,k)=g_to_vol(k)
+      if ((do_ray == 1) .and. (z_ray(k) > 0)) then
+        Ze_ray(pr,k) = 10*log10(z_ray(k))
+      else
+        Ze_ray(pr,k) = -999
+      endif
+      if (z_vol(k) > 0) then
+        dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k)
+        Ze_non(pr,k) = 10*log10(z_vol(k))
+      else
+        dBZe(pr,k) = -999
+        Ze_non(pr,k) = -999
+      endif
+      
+    enddo	! end loop of k (range gate)
+    ! Output array with gaseous absorption
+    if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol
+  enddo		! end loop over pr (profile)  
+
+  end subroutine radar_simulator
+  
Index: LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator_types.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator_types.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator_types.F90	(revision 2298)
@@ -0,0 +1,55 @@
+  module radar_simulator_types
+
+! Collection of common variables and types
+! Part of QuickBeam v1.03 by John Haynes
+! http://reef.atmos.colostate.edu/haynes/radarsim
+
+  integer, parameter ::       &
+  maxhclass = 20 	     ,& ! max number of hydrometeor classes
+  nd = 85		     ,& ! number of discrete particles  
+  nRe_types = 250		! number or Re size bins allowed in N and Z_scaled look up table
+
+  real*8, parameter ::        &
+  dmin = 0.1                 ,& ! min size of discrete particle
+  dmax = 10000.                	! max size of discrete particle
+   
+  integer, parameter :: &
+  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
+
+
+! ---- hydrometeor class type -----  
+  
+  type class_param
+    real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
+    integer, dimension(maxhclass) :: dtype,col,cp,phase
+    logical, dimension(maxhclass,nRe_types) :: scaled
+    logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_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
+    integer, dimension(maxhclass,nd,nRe_types) :: ifc
+    integer, dimension(maxhclass) :: idd
+  end type class_param
+
+! ----- mie table structure -----
+  
+  type mie
+    real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd)
+    real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca
+    integer :: phase(mt_ntt)
+  end type mie
+
+  real*8, dimension(:), save, allocatable :: &
+    mt_ttl, &			! liquid temperatures (C)
+    mt_tti, &			! ice temperatures (C)
+    mt_qext, mt_qbsca		! extincion/backscatter efficiency
+!$OMP THREADPRIVATE(mt_ttl,mt_tti,mt_qext, mt_qbsca)
+
+  integer*4,save :: &
+    cnt_liq, &			! liquid temperature count
+    cnt_ice			! ice temperature count
+!$OMP THREADPRIVATE(cnt_liq,cnt_ice)
+
+  end module radar_simulator_types
Index: LMDZ5/branches/testing/libf/phylmd/cosp/read_cosp_output_nl.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/read_cosp_output_nl.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/read_cosp_output_nl.F90	(revision 2298)
@@ -0,0 +1,232 @@
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ SUBROUTINE READ_COSP_OUTPUT_NL(cosp_nl,cfg)
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE mod_phys_lmdz_para
+  character(len=*),intent(in) :: cosp_nl
+  type(cosp_config),intent(out) :: cfg
+  ! Local variables
+  integer :: i
+
+  logical, save ::   Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
+             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
+             Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfrac_out,Lbeta_mol532,Ltbrttov
+
+  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, &
+             Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfrac_out,Lbeta_mol532,Ltbrttov
+
+  do i=1,N_OUT_LIST
+    cfg%out_list(i)=''
+  enddo
+  
+  IF (is_master) THEN
+    open(10,file=cosp_nl,status='old')
+    read(10,nml=cosp_output)
+    close(10)
+  ENDIF
+  
+  CALL bcast(Lradar_sim)
+  CALL bcast(Llidar_sim)
+  CALL bcast(Lisccp_sim)
+  CALL bcast(Lmisr_sim)
+  CALL bcast(Lrttov_sim)
+  CALL bcast(Lalbisccp)
+  CALL bcast(Latb532)
+  CALL bcast(Lboxptopisccp)
+  CALL bcast(Lboxtauisccp)
+  CALL bcast(Lcfad_dbze94)
+  CALL bcast(Lcfad_lidarsr532)
+  CALL bcast(Lclcalipso2)
+  CALL bcast(Lclcalipso)
+  CALL bcast(Lclhcalipso)
+  CALL bcast(Lclisccp2)
+  CALL bcast(Lcllcalipso)
+  CALL bcast(Lclmcalipso)
+  CALL bcast(Lcltcalipso)
+  CALL bcast(Lcltlidarradar)
+  CALL bcast(Lctpisccp)
+  CALL bcast(Ldbze94)
+  CALL bcast(Ltauisccp)
+  CALL bcast(Ltclisccp)
+  CALL bcast(Llongitude)
+  CALL bcast(Llatitude)
+  CALL bcast(Lparasol_refl)
+  CALL bcast(LclMISR)
+  CALL bcast(Lmeantbisccp)
+  CALL bcast(Lmeantbclrisccp)
+  CALL bcast(Lfrac_out)
+  CALL bcast(Lbeta_mol532)
+  CALL bcast(Ltbrttov)
+!$OMP BARRIER
+
+!  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
+    Lcfad_dbze94   = .false.
+    Lclcalipso2    = .false.
+    Lcltlidarradar = .false.
+    Ldbze94        = .false.
+  endif
+  if (.not.Llidar_sim) then
+    Latb532 = .false.
+    Lcfad_lidarsr532 = .false.
+    Lclcalipso2      = .false.
+    Lclcalipso       = .false.
+    Lclhcalipso      = .false.
+    Lcllcalipso      = .false.
+    Lclmcalipso      = .false.
+    Lcltcalipso      = .false.
+    Lcltlidarradar   = .false.
+    Lparasol_refl    = .false.
+    Lbeta_mol532     = .false.
+  endif
+  if (.not.Lisccp_sim) then
+    Lalbisccp       = .false.
+    Lboxptopisccp   = .false.
+    Lboxtauisccp    = .false.
+    Lclisccp2       = .false.
+    Lctpisccp       = .false.
+    Ltauisccp       = .false.
+    Ltclisccp       = .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
+    Lfrac_out = .false.
+  endif
+
+  ! 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
+
+  cfg%Lstats = .false.
+  if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) cfg%Lstats = .true.
+
+  ! Copy instrument flags to cfg structure
+  cfg%Lradar_sim = Lradar_sim
+  cfg%Llidar_sim = Llidar_sim
+  cfg%Lisccp_sim = Lisccp_sim
+  cfg%Lmisr_sim  = Lmisr_sim
+  cfg%Lrttov_sim = Lrttov_sim
+
+  ! 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 (Lcfad_dbze94)     cfg%out_list(i) = 'cfad_dbze94'
+  i = i+1
+  if (Lcfad_lidarsr532) cfg%out_list(i) = 'cfad_lidarsr532'
+  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 (Lclisccp2)        cfg%out_list(i) = 'clisccp2'
+  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 (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
+  i = i+1
+  if (Lctpisccp)        cfg%out_list(i) = 'ctpisccp'
+  i = i+1
+  if (Ldbze94)          cfg%out_list(i) = 'dbze94'
+  i = i+1
+  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
+  i = i+1
+  if (Ltclisccp)        cfg%out_list(i) = 'tclisccp'
+  i = i+1
+  if (Llongitude)       cfg%out_list(i) = 'lon'
+  i = i+1
+  if (Llatitude)        cfg%out_list(i) = 'lat'
+  i = i+1
+  if (Lparasol_refl)    cfg%out_list(i) = 'parasol_refl'
+  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 (Lfrac_out)        cfg%out_list(i) = 'frac_out'
+  i = i+1
+  if (Lbeta_mol532)     cfg%out_list(i) = 'beta_mol532'
+  i = i+1
+  if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
+
+  if (i /= N_OUT_LIST) then
+     print *, 'COSP_IO: wrong number of output diagnostics'
+     stop
+  endif
+
+  ! Copy diagnostic flags to cfg structure
+  cfg%Lalbisccp = Lalbisccp
+  cfg%Latb532 = Latb532
+  cfg%Lboxptopisccp = Lboxptopisccp
+  cfg%Lboxtauisccp = Lboxtauisccp
+  cfg%Lcfad_dbze94 = Lcfad_dbze94
+  cfg%Lcfad_lidarsr532 = Lcfad_lidarsr532
+  cfg%Lclcalipso2 = Lclcalipso2
+  cfg%Lclcalipso = Lclcalipso
+  cfg%Lclhcalipso = Lclhcalipso
+  cfg%Lclisccp2 = Lclisccp2
+  cfg%Lcllcalipso = Lcllcalipso
+  cfg%Lclmcalipso = Lclmcalipso
+  cfg%Lcltcalipso = Lcltcalipso
+  cfg%Lcltlidarradar = Lcltlidarradar
+  cfg%Lctpisccp = Lctpisccp
+  cfg%Ldbze94 = Ldbze94
+  cfg%Ltauisccp = Ltauisccp
+  cfg%Ltclisccp = Ltclisccp
+  cfg%Llongitude = Llongitude
+  cfg%Llatitude = Llatitude
+  cfg%Lparasol_refl = Lparasol_refl
+  cfg%LclMISR = LclMISR
+  cfg%Lmeantbisccp = Lmeantbisccp
+  cfg%Lmeantbclrisccp = Lmeantbclrisccp
+  cfg%Lfrac_out = Lfrac_out
+  cfg%Lbeta_mol532 = Lbeta_mol532
+  cfg%Ltbrttov = Ltbrttov
+
+ END SUBROUTINE READ_COSP_OUTPUT_NL
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/scops.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/scops.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/scops.F	(revision 2298)
@@ -0,0 +1,339 @@
+      subroutine scops(npoints,nlev,ncol,seed,cc,conv,
+     &                 overlap,frac_out,ncolprint)
+
+
+! *****************************COPYRIGHT****************************
+! (c) British Crown Copyright 2009, 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.  
+! 
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+! *****************************COPYRIGHT*******************************
+
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+
+      implicit none
+
+      INTEGER npoints       !  number of model points in the horizontal
+      INTEGER nlev          !  number of model levels in column
+      INTEGER ncol          !  number of subcolumns
+
+
+      INTEGER overlap         !  overlap type
+                              !  1=max
+                              !  2=rand
+                              !  3=max/rand
+      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
+
+      INTEGER i,j,ilev,ibox,ncolprint,ilev2
+
+      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
+
+
+      INTEGER seed(npoints)
+      !  seed values for marsaglia  random number generator
+      !  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 same
+      !  seed value every time may introduce some
+      !  statistical bias in the results, particularly
+      !  for low values of NCOL.
+
+      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 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 ran(npoints)                 ! vector of random numbers
+
+      INTEGER irand,i2_16,huge32,overflow_32  ! variables for RNG
+      PARAMETER(huge32=2147483647)
+      i2_16=65536
+
+      do ibox=1,ncol
+        do j=1,npoints 
+        boxpos(j,ibox)=(ibox-.5)/ncol
+        enddo
+      enddo
+
+!     ---------------------------------------------------!
+!     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
+          enddo
+        enddo
+      enddo
+
+!     assign 2d tca array using 1d input array cc
+
+      do j=1,npoints
+        tca(j,0)=0
+      enddo
+
+      do ilev=1,nlev
+        do j=1,npoints
+          tca(j,ilev)=cc(j,ilev)
+        enddo
+      enddo
+
+      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 200 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
+              DO ibox=1,ncol
+                do j=1,npoints
+                  threshold(j,ibox)=boxpos(j,ibox)
+                enddo
+              enddo
+          ELSE
+              DO ibox=1,ncol
+!                include 'congvec_para.h'
+                 include 'congvec.h'
+                ! 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)=
+     &            conv(j,ilev)+(1-conv(j,ilev))*ran(j)
+                enddo
+              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
+          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 
+            do j=1,npoints
+              threshold_min(j,ibox)=conv(j,ilev)
+              maxosc(j,ibox)=1
+            enddo
+          endif
+
+          ! Random overlap
+          if (overlap.eq.2) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=conv(j,ilev)
+              maxosc(j,ibox)=0
+            enddo
+          endif
+
+          ! Max/Random overlap
+          if (overlap.eq.3) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=max(conv(j,ilev),
+     &          min(tca(j,ilev-1),tca(j,ilev)))
+              if (threshold(j,ibox)
+     &          .lt.min(tca(j,ilev-1),tca(j,ilev))
+     &          .and.(threshold(j,ibox).gt.conv(j,ilev))) then
+                   maxosc(j,ibox)= 1
+              else
+                   maxosc(j,ibox)= 0
+              end if
+            enddo
+          endif
+    
+          ! Reset threshold 
+
+          include 'congvec.h'
+
+          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)  
+     &           ) 
+     &        )
+          enddo
+
+        ENDDO ! 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).gt.threshold(j,ibox)) then
+               frac_out(j,ibox,ilev)=1
+               else
+               frac_out(j,ibox,ilev)=0
+               end if               
+             enddo
+           ENDDO
+
+!         Code to partition boxes into startiform and convective parts
+!         goes here
+
+           DO ibox=1,ncol
+             do j=1,npoints 
+                if (threshold(j,ibox).le.conv(j,ilev)) then
+                    ! = 2 IF threshold le conv(j)
+                    frac_out(j,ibox,ilev) = 2 
+                else
+                    ! = the same IF NOT threshold le conv(j) 
+                    frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
+                end if
+             enddo
+           ENDDO
+
+!         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-1))
+    
+            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
+
+200   CONTINUE    !loop over nlev
+
+
+      end
+
Index: LMDZ5/branches/testing/libf/phylmd/cosp/zeff.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cosp/zeff.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/cosp/zeff.F90	(revision 2298)
@@ -0,0 +1,161 @@
+  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 (C)
+!   [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 :: &
+  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), dqxt, dqsc, dbsc, 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
+    call avint(qbsca*N0*D0**2,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
+    call avint(qext*N0*D0**2,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
+      call avint(N0*D0**6,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: LMDZ5/branches/testing/libf/phylmd/cv3_routines.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cv3_routines.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cv3_routines.F90	(revision 2298)
@@ -5,5 +5,5 @@
 
 
-SUBROUTINE cv3_param(nd, delt)
+SUBROUTINE cv3_param(nd, k_upper, delt)
 
   use mod_phys_lmdz_para
@@ -36,6 +36,7 @@
   include "conema3.h"
 
-  INTEGER nd
-  REAL delt ! timestep (seconds)
+  INTEGER, INTENT(IN)              :: nd
+  INTEGER, INTENT(IN)              :: k_upper
+  REAL, INTENT(IN)                 :: delt ! timestep (seconds)
 
 
@@ -51,5 +52,10 @@
 ! -- limit levels for convection:
 
-  noff = 1
+!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
@@ -264,23 +270,22 @@
 
 !inputs:
-  INTEGER len, nd
-  LOGICAL ok_conserv_q
-  REAL t(len, nd), q(len, nd), p(len, nd)
-  REAL u(len, nd), v(len, nd)
-  REAL hm(len, nd), gz(len, nd)
-  REAL ph(len, nd+1)
-  REAL p1feed(len)
-! ,  wght(len)
-  REAL wght(nd)
+  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)             :: hm, gz
+  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph
+  REAL, DIMENSION (len), INTENT (IN)                 :: p1feed
+  REAL, DIMENSION (nd), INTENT (IN)                  :: wght
 !input-output
-  REAL p2feed(len)
+  REAL, DIMENSION (len), INTENT (INOUT)              :: p2feed
 !outputs:
-  INTEGER iflag(len), nk(len), icb(len), icbmax
-!   real   wghti(len)
-  REAL wghti(len, nd)
-  REAL tnk(len), thnk(len), qnk(len), qsnk(len)
-  REAL unk(len), vnk(len)
-  REAL cpnk(len), hnk(len), gznk(len)
-  REAL plcl(len)
+  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:
@@ -514,22 +519,23 @@
 
 ! inputs:
-  INTEGER len, nd
-  INTEGER icb(len)
-  REAL t(len, nd), qs(len, nd), gz(len, nd)
-  REAL tnk(len), qnk(len), gznk(len)
-  REAL p(len, nd)
-  REAL plcl(len) ! convect3
+  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:
-  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
+  INTEGER, DIMENSION (len), INTENT (OUT)            :: icbs
+  REAL, DIMENSION (len, nd), INTENT (OUT)           :: tp, tvp, clw
 
 ! local variables:
   INTEGER i, k
-  INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
+  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
+  REAL qsicb(len)                                                        ! convect3
+  REAL cpinv(len)                                                        ! convect3
 
 ! -------------------------------------------------------------------
@@ -1051,21 +1057,24 @@
 
 !inputs:
-  INTEGER ncum, nd, nloc, j
-  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 hnk(nloc)
-  REAL lv(nloc, nd), lf(nloc, nd), tv(nloc, nd), h(nloc, nd)
-  REAL pbase(nloc), buoybase(nloc), plcl(nloc)
+  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), 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
 
 !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)
+  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: inb
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ep, sigp, hp
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: buoy
 
 !local variables:
-  INTEGER i, k
+  INTEGER i, j, k
   REAL tg, qg, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
   REAL als
@@ -1084,6 +1093,4 @@
   DO k = 1, nl
     DO i = 1, ncum
-      ep(i, k) = 0.0
-      sigp(i, k) = spfac
       qi(i, k) = 0.
     END DO
@@ -1187,5 +1194,7 @@
           END IF
         END IF
-      END IF
+!jyg<
+!!      END IF  ! Endif moved to the end of the loop
+!>jyg
 
       IF (cvflag_ice) THEN
@@ -1258,5 +1267,7 @@
         END IF
       END IF ! (cvflag_ice)
-
+!jyg<
+      END IF ! (k>=(icbs(i)+1))
+!>jyg
     END DO
   END DO
@@ -1267,13 +1278,26 @@
 ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
 ! =====================================================================
-
+!
+!jyg<
+  DO k = 1, nl
+    DO i = 1, ncum
+      ep(i, k) = 0.0
+      sigp(i, k) = spfac
+    END DO
+  END DO
+!>jyg
+!
   IF (flag_epkeorig/=1) THEN
     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) = max(ep(i,k), 0.0)
-        ep(i, k) = min(ep(i,k), epmax)
-        sigp(i, k) = spfac
+!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
@@ -1281,5 +1305,7 @@
     DO k = 1, nl
       DO i = 1, ncum
-        IF (k>=(nk(i)+1)) THEN
+        IF(k>=icb(i)) THEN
+!!        IF (k>=(nk(i)+1)) THEN
+!>jyg
           tca = tp(i, k) - t0
           IF (tca>=0.0) THEN
@@ -1292,9 +1318,10 @@
           ep(i, k) = max(ep(i,k), 0.0)
           ep(i, k) = min(ep(i,k), epmax)
-          sigp(i, k) = spfac
-        END IF
+!!          sigp(i, k) = spfac  ! jyg
+        END IF  ! (k>=icb(i))
       END DO
     END DO
   END IF
+!
 ! =====================================================================
 ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
@@ -1331,6 +1358,7 @@
 ! first estimate of buoyancy:
 
-  DO i = 1, ncum
-    DO k = 1, nl
+!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
@@ -1340,10 +1368,13 @@
 ! for safety, set buoy(icb)=buoybase
 
-  DO i = 1, ncum
-    DO k = 1, nl
+!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)
@@ -1490,21 +1521,30 @@
   END DO
 
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-
-        IF (cvflag_ice) THEN
+!jyg : cvflag_ice test outside the loops (07042015)
+!
+  IF (cvflag_ice) THEN
+!
+    DO k = minorig + 1, nl
+      DO i = 1, ncum
+        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
           frac(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
           frac(i, k) = min(max(frac(i,k),0.0), 1.0)
           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)
-
-        ELSE
+        END IF
+      END DO
+    END DO
+!
+  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))*ep(i, k)*clw(i, k)
         END IF
-
-      END IF
-    END DO
-  END DO
+      END DO
+    END DO
+!
+  END IF  ! (cvflag_ice)
 
   RETURN
@@ -1768,25 +1808,24 @@
 
 !inputs:
-  INTEGER ncum, nd, na, ntra, nloc
-  INTEGER icb(nloc), inb(nloc), nk(nloc)
-  REAL sig(nloc, nd)
-  REAL qnk(nloc), unk(nloc), vnk(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 lf(nloc, na), frac(nloc, na)
-  REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
-  REAL m(nloc, na) ! input of convect3
+  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 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)
-  INTEGER nent(nloc, nd)
+  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:
@@ -1797,4 +1836,5 @@
   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)
@@ -2184,4 +2224,5 @@
   include "cv3param.h"
   include "cvflag.h"
+  include "nuage.h"
 
 !inputs:
@@ -2363,5 +2404,6 @@
 
           IF (cvflag_ice) THEN
-            thaw = (t(il,i)-273.15)/(275.15-273.15)
+!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)
             frac(il, i) = frac(il, i)*(1.-thaw)
@@ -2477,5 +2519,6 @@
           f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
 
-          thaw = (t(il,i)-273.15)/(275.15-273.15)
+!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)
           water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
@@ -2763,5 +2806,6 @@
                      iflag, precip, Vprecip, ft, fr, fu, fv, ftra, &
                      cbmf, upwd, dnwd, dnwd0, ma, mip, &
-                     tls, tps, qcondc, wd, &
+!!                     tls, tps,                             ! useless . jyg
+                     qcondc, wd, &
                      ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
 
@@ -2811,5 +2855,5 @@
       REAL dnwd0(nloc, nd), mip(nloc, nd)
       REAL Vprecip(nloc, nd+1)
-      REAL tls(nloc, nd), tps(nloc, nd)
+!!      REAL tls(nloc, nd), tps(nloc, nd)                 ! useless . jyg
       REAL qcondc(nloc, nd) ! cld
       REAL qtc(nloc,nd), sigt(nloc,nd) ! cld
@@ -2823,5 +2867,5 @@
       REAL cpinv, rdcp, dpinv
       REAL awat(nloc)
-      REAL lvcp(nloc, na), lfcp(nloc, na), mke(nloc, na)
+      REAL lvcp(nloc, na), lfcp(nloc, na)                  ! , mke(nloc, na) ! unused . jyg
       REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
 !!      real up1(nloc), dn1(nloc)
@@ -3588,6 +3632,11 @@
 ! ***           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
-    sig(il, nd) = 2.0
+    IF (iflag(il) < 3) THEN
+      sig(il, nd) = 2.0
+    ENDIF
   END DO
 
@@ -3743,17 +3792,17 @@
 ! 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
+!!  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
 
 
Index: LMDZ5/branches/testing/libf/phylmd/cv3a_compress.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cv3a_compress.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cv3a_compress.F90	(revision 2298)
@@ -1,11 +1,23 @@
-SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, 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)
+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)
   ! **************************************************************
   ! *
@@ -22,44 +34,58 @@
 
   ! inputs:
-  INTEGER len, nloc, ncum, nd, ntra
-  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
-  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
-  REAL hnk1(len), unk1(len), vnk1(len)
-  REAL wghti1(len, nd), pbase1(len), buoybase1(len)
-  REAL t1(len, nd), q1(len, nd), qs1(len, nd)
-  REAL t1_wake(len, nd), q1_wake(len, nd), qs1_wake(len, nd)
-  REAL s1_wake(len)
-  REAL u1(len, nd), v1(len, nd)
-  REAL gz1(len, nd), th1(len, nd), th1_wake(len, nd)
-  REAL tra1(len, nd, ntra)
-  REAL h1(len, nd), lv1(len, nd), lf1(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 h1_wake(len, nd), lv1_wake(len, nd), cpn1_wake(len, nd)
-  REAL tv1_wake(len, nd), lf1_wake(len, nd)
-  REAL sig1(len, nd), w01(len, nd), ptop21(len)
-  REAL ale1(len), alp1(len)
-  REAL omega1(len,nd)
-
+  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 iflag(len), nk(len), icb(len), icbs(len)
-  REAL plcl(len), tnk(len), qnk(len), gznk(len)
-  REAL hnk(len), unk(len), vnk(len)
-  REAL wghti(len, nd), pbase(len), buoybase(len)
-  REAL t(len, nd), q(len, nd), qs(len, nd)
-  REAL t_wake(len, nd), q_wake(len, nd), qs_wake(len, nd)
-  REAL s_wake(len)
-  REAL u(len, nd), v(len, nd)
-  REAL gz(len, nd), th(len, nd), th_wake(len, nd)
-  REAL tra(len, nd, ntra)
-  REAL h(len, nd), lv(len, nd), lf(len, nd), cpn(len, nd)
-  REAL p(len, nd), ph(len, nd+1), tv(len, nd), tp(len, nd)
-  REAL tvp(len, nd), clw(len, nd)
-  REAL h_wake(len, nd), lv_wake(len, nd), cpn_wake(len, nd)
-  REAL tv_wake(len, nd), lf_wake(len, nd)
-  REAL sig(len, nd), w0(len, nd), ptop2(len)
-  REAL ale(len), alp(len)
-  REAL omega(len,nd)
+  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:
@@ -69,4 +95,7 @@
   CHARACTER (LEN=80) :: abort_message
 
+!jyg<
+  IF (compress) THEN
+!>jyg
 
   DO k = 1, nl + 1
@@ -108,5 +137,5 @@
     END DO
   END DO
-
+!
   ! AC!      do 121 j=1,ntra
   ! AC!ccccc      do 111 k=1,nl+1
@@ -146,7 +175,8 @@
       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)
+      Ale(nn) = Ale1(i)
+      Alp(nn) = Alp1(i)
     END IF
   END DO
@@ -157,4 +187,62 @@
     CALL abort_gcm(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
Index: LMDZ5/branches/testing/libf/phylmd/cv3a_uncompress.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cv3a_uncompress.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cv3a_uncompress.F90	(revision 2298)
@@ -1,19 +1,30 @@
-SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, kbas, &
-    ktop, precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, ft, fq, fu, fv, &
-    ftra, sigd, ma, mip, vprecip, 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
-    , clw, elij, evap, ep, epmlmmm, eplamm & ! RomP
-    , wdtraina, wdtrainm &         ! RomP
-    , qtc, sigt          &
-
-    , iflag1, kbas1, ktop1, precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, &
-    ptop21, ft1, fq1, fu1, fv1, ftra1, sigd1, ma1, mip1, vprecip1, 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
-    , clw1, elij1, evap1, ep1, epmlmmm1, eplamm1 & ! RomP
-    , wdtraina1, wdtrainm1 & ! RomP
-    , qtc1, sigt1)
+SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
+                           iflag, kbas, ktop, &
+                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
+                           ft, fq, fu, fv, ftra,  &
+                           sigd, ma, mip, vprecip, 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
+                           clw, elij, evap, ep, epmlmMm, eplaMm, &              ! RomP
+                           wdtrainA, wdtrainM, &                                ! RomP
+                           qtc, sigt,          &
+                         
+                           iflag1, kbas1, ktop1, &
+                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
+                           ft1, fq1, fu1, fv1, ftra1, &
+                           sigd1, ma1, mip1, vprecip1, 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
+                           clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &        ! RomP
+                           wdtrainA1, wdtrainM1, &                              ! RomP
+                           qtc1, sigt1)
 
   ! **************************************************************
@@ -31,161 +42,246 @@
 
   ! inputs:
-  INTEGER nloc, len, ncum, nd, ntra
-  INTEGER idcum(nloc)
-  INTEGER iflag(nloc), kbas(nloc), ktop(nloc)
-  REAL precip(nloc), cbmf(nloc), plcl(nloc), plfc(nloc)
-  REAL wbeff(len)
-  REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ftra(nloc, nd, ntra)
-  REAL sigd(nloc)
-  REAL ma(nloc, nd), mip(nloc, nd), vprecip(nloc, nd+1)
-  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
-  REAL qcondc(nloc, nd)
-  REAL wd(nloc), cape(nloc), cin(nloc)
-  REAL tvp(nloc, nd)
-  REAL ftd(nloc, nd), fqd(nloc, nd)
-  REAL plim1(nloc), plim2(nloc)
-  REAL asupmax(nloc, nd), supmax0(nloc)
-  REAL asupmaxmin(nloc)
-
-  REAL da(nloc, nd), phi(nloc, nd, nd) !AC!
-  REAL mp(nloc, nd) !RomP
-  REAL phi2(nloc, nd, nd) !RomP
-  REAL d1a(nloc, nd), dam(nloc, nd) !RomP
-  REAL sigij(nloc, nd, nd) !RomP
-  REAL clw(nloc, nd), elij(nloc, nd, nd) !RomP
-  REAL evap(nloc, nd), ep(nloc, nd) !RomP
-  REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd) !RomP+jyg
-  REAL qtc(nloc, nd), sigt(nloc, nd) !RomP
-  REAL wdtraina(nloc, nd), wdtrainm(nloc, nd) !RomP
+  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, nd), INTENT (IN)            :: ft, fq, 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), 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)            :: 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              !RomP
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainM     !RomP
 
   ! outputs:
-  INTEGER iflag1(len), kbas1(len), ktop1(len)
-  REAL precip1(len), cbmf1(len), plcl1(nloc), plfc1(nloc)
-  REAL wbeff1(len)
-  REAL sig1(len, nd), w01(len, nd), ptop21(len)
-  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
-  REAL ftra1(len, nd, ntra)
-  REAL sigd1(len)
-  REAL ma1(len, nd), mip1(len, nd), vprecip1(len, nd+1)
-  REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
-  REAL qcondc1(len, nd)
-  REAL wd1(len), cape1(len), cin1(len)
-  REAL tvp1(len, nd)
-  REAL ftd1(len, nd), fqd1(len, nd)
-  REAL plim11(len), plim21(len)
-  REAL asupmax1(len, nd), supmax01(len)
-  REAL asupmaxmin1(len)
-
-  REAL da1(nloc, nd), phi1(nloc, nd, nd) !AC!
-  REAL mp1(nloc, nd) !RomP
-  REAL phi21(nloc, nd, nd) !RomP
-  REAL d1a1(nloc, nd), dam1(nloc, nd) !RomP
-  REAL sigij1(len, nd, nd) !RomP
-  REAL clw1(len, nd), elij1(len, nd, nd) !RomP
-  REAL evap1(len, nd), ep1(len, nd) !RomP
-  REAL epmlmmm1(len, nd, nd), eplamm1(len, nd) !RomP+jyg
-  REAL qtc1(len, nd), sigt1(len, nd) !RomP
-  REAL wdtraina1(len, nd), wdtrainm1(len, nd) !RomP
+  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)                :: ptop21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1, fq1, 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), 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)            :: 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            !RomP
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1   !RomP
 
 
   ! local variables:
   INTEGER i, k, j
+  INTEGER jdcum
   ! c    integer k1,k2
 
-  DO i = 1, ncum
-    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)
-  END DO
-
-  DO k = 1, nd
+!jyg<
+  IF (compress) THEN
+!>jyg
     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)
-      mip1(idcum(i), k) = mip(i, k)
-      vprecip1(idcum(i), k) = vprecip(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
-      clw1(idcum(i), k) = clw(i, k) !RomP
-      evap1(idcum(i), k) = evap(i, k) !RomP
-      ep1(idcum(i), k) = ep(i, k) !RomP
-      eplamm(idcum(i), k) = eplamm(i, k) !RomP+jyg
-      wdtraina1(idcum(i), k) = wdtraina(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)
-
+      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)
     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
-
-  ! AC!
-  DO j = 1, nd
-    DO k = 1, nd
+   
+    DO k = 1, nl+1
       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
+        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)
+        mip1(idcum(i), k) = mip(i, k)
+        vprecip1(idcum(i), k) = vprecip(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
+        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
+        wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP
+        qtc1(idcum(i), k) = qtc(i, k)
+        sigt1(idcum(i), k) = sigt(i, k)
+   
       END DO
     END DO
-  END DO
-  ! 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
+   
+    ! 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
+!>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+1) = sig(:, 1:nl+1)
+      w01(:, 1:nl+1) = w0(:, 1:nl+1)
+      ft1(:, 1:nl+1) = ft(:, 1:nl+1)
+      fq1(:, 1:nl+1) = fq(:, 1:nl+1)
+      fu1(:, 1:nl+1) = fu(:, 1:nl+1)
+      fv1(:, 1:nl+1) = fv(:, 1:nl+1)
+      ma1(:, 1:nl+1) = ma(:, 1:nl+1)
+      mip1(:, 1:nl+1) = mip(:, 1:nl+1)
+      vprecip1(:, 1:nl+1) = vprecip(:, 1:nl+1)
+      upwd1(:, 1:nl+1) = upwd(:, 1:nl+1)
+      dnwd1(:, 1:nl+1) = dnwd(:, 1:nl+1)
+      dnwd01(:, 1:nl+1) = dnwd0(:, 1:nl+1)
+      qcondc1(:, 1:nl+1) = qcondc(:, 1:nl+1)
+      tvp1(:, 1:nl+1) = tvp(:, 1:nl+1)
+      ftd1(:, 1:nl+1) = ftd(:, 1:nl+1)
+      fqd1(:, 1:nl+1) = fqd(:, 1:nl+1)
+      asupmax1(:, 1:nl+1) = asupmax(:, 1:nl+1)
+
+      da1(:, 1:nl+1) = da(:, 1:nl+1)              !AC!
+      mp1(:, 1:nl+1) = mp(:, 1:nl+1)              !RomP
+      d1a1(:, 1:nl+1) = d1a(:, 1:nl+1)            !RomP
+      dam1(:, 1:nl+1) = dam(:, 1:nl+1)            !RomP
+      clw1(:, 1:nl+1) = clw(:, 1:nl+1)            !RomP
+      evap1(:, 1:nl+1) = evap(:, 1:nl+1)          !RomP
+      ep1(:, 1:nl+1) = ep(:, 1:nl+1)              !RomP
+      eplamM1(:, 1:nl+1) = eplamM(:, 1:nl+1)       !RomP+jyg
+      wdtrainA1(:, 1:nl+1) = wdtrainA(:, 1:nl+1)  !RomP
+      wdtrainM1(:, 1:nl+1) = wdtrainM(:, 1:nl+1)  !RomP
+      qtc1(:, 1:nl+1) = qtc(:, 1:nl+1)
+      sigt1(:, 1:nl+1) = sigt(:, 1:nl+1)
+!
+      phi1    (:, 1:nl+1, 1:nl+1) = phi    (:, 1:nl+1, 1:nl+1)  !AC!
+      phi21   (:, 1:nl+1, 1:nl+1) = phi2   (:, 1:nl+1, 1:nl+1)  !RomP
+      sigij1  (:, 1:nl+1, 1:nl+1) = sigij  (:, 1:nl+1, 1:nl+1)  !RomP
+      elij1   (:, 1:nl+1, 1:nl+1) = elij   (:, 1:nl+1, 1:nl+1)  !RomP
+      epmlmMm1(:, 1:nl+1, 1:nl+1) = epmlmMm(:, 1:nl+1, 1:nl+1)  !RomP+jyg
+  ENDIF !(compress)
+!>jyg
 
   RETURN
Index: LMDZ5/branches/testing/libf/phylmd/cv3p1_closure.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cv3p1_closure.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cv3p1_closure.F90	(revision 2298)
@@ -29,26 +29,29 @@
 
   ! 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), buoy(nloc, nd)
-  REAL supmax(nloc, nd)
-  LOGICAL ok_inhib ! enable convection inhibition by dryness
-  REAL ale(nloc), alp(nloc)
-  REAL omega(nloc,nd)
+  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:
-  REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
+  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
+  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
 
   ! output:
-  REAL cape(nloc), cin(nloc)
-  REAL m(nloc, nd)
-  REAL plim1(nloc), plim2(nloc)
-  REAL asupmax(nloc, nd), supmax0(nloc)
-  REAL asupmaxmin(nloc)
-  REAL cbmf(nloc), plfc(nloc)
-  REAL wbeff(nloc)
-  INTEGER iflag(nloc)
+  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
+  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: iflag
 
   ! local variables:
@@ -91,5 +94,4 @@
 
 
-
   DO il = 1, ncum
     alp2(il) = max(alp(il), 1.E-5)
@@ -498,9 +500,8 @@
   IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim'
 
-  ! c 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
-  ! c     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
-  ! c     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud)
-  ! is
-  ! --    exceedingly small.
+  ! 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
Index: LMDZ5/branches/testing/libf/phylmd/cv3param.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cv3param.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cv3param.h	(revision 2298)
@@ -19,7 +19,5 @@
       real betad
 
-      COMMON /cv3param/  noff, minorig, nl, nlp, nlm &
-                      ,  sigdz, spfac &
-                      ,flag_epKEorig &
+      COMMON /cv3param/ sigdz, spfac &
                       ,pbcrit, ptcrit &
                       ,elcrit, tlcrit &
@@ -27,6 +25,9 @@
                       ,dtovsh, dpbase, dttrig &
                       ,dtcrit, tau, beta, alpha, alpha1 &
-                      ,flag_wb,wbmax &
-                      ,delta, betad
+                      ,wbmax &
+                      ,delta, betad  &
+                      ,flag_epKEorig &
+                      ,flag_wb &
+                      ,noff, minorig, nl, nlp, nlm
 !$OMP THREADPRIVATE(/cv3param/)
 
Index: LMDZ5/branches/testing/libf/phylmd/cva_driver.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cva_driver.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cva_driver.F90	(revision 2298)
@@ -2,7 +2,9 @@
 ! $Id$
 
-SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, &
+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, &
+!!                      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, &
@@ -19,5 +21,5 @@
                       ftd1, fqd1, &
                       Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, &
-                      lalim_conv, & 
+                      lalim_conv1, & 
 !!                      da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, &        ! RomP
 !!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
@@ -52,4 +54,6 @@
 ! 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)
@@ -60,4 +64,6 @@
 ! 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)
@@ -156,67 +162,72 @@
   include 'iniprint.h'
 
-
 ! Input
-  INTEGER len
-  INTEGER nd
-  INTEGER ndp1
-  INTEGER ntra
-  INTEGER iflag_con
-  INTEGER iflag_mix
-  INTEGER iflag_ice_thermo
-  INTEGER iflag_clos
-  LOGICAL ok_conserv_q
-  REAL tau_cld_cv
-  REAL coefw_cld_cv
-  REAL delt
-  REAL t1(len, nd)
-  REAL q1(len, nd)
-  REAL qs1(len, nd)
-  REAL t1_wake(len, nd)
-  REAL q1_wake(len, nd)
-  REAL qs1_wake(len, nd)
-  REAL s1_wake(len)
-  REAL u1(len, nd)
-  REAL v1(len, nd)
-  REAL tra1(len, nd, ntra)
-  REAL p1(len, nd)
-  REAL ph1(len, ndp1)
-  REAL Ale1(len)
-  REAL Alp1(len)
-  REAL omega1(len,nd)
-  REAL sig1feed1 ! pressure at lower bound of feeding layer
-  REAL sig2feed1 ! pressure at upper bound of feeding layer
-  REAL wght1(nd) ! weight density determining the feeding mixture
+  INTEGER, INTENT (IN)                               :: len
+  INTEGER, INTENT (IN)                               :: nd
+  INTEGER, INTENT (IN)                               :: ndp1
+  INTEGER, INTENT (IN)                               :: ntra
+  INTEGER, INTENT(IN)                                :: nloc ! (nloc=klon)  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 iflag1(len)
-  REAL ft1(len, nd)
-  REAL fq1(len, nd)
-  REAL fu1(len, nd)
-  REAL fv1(len, nd)
-  REAL ftra1(len, nd, ntra)
-  REAL precip1(len)
-  INTEGER kbas1(len)
-  INTEGER ktop1(len)
-  REAL cbmf1(len)
-  REAL plcl1(klon)
-  REAL plfc1(klon)
-  REAL wbeff1(klon)
-  REAL sig1(len, klev) !input/output
-  REAL w01(len, klev) !input/output
-  REAL ptop21(len)
-  REAL sigd1(len)
-  REAL ma1(len, nd)
-  REAL mip1(len, nd)
+  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)            :: 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
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mip1
 ! real Vprecip1(len,nd)
-  REAL vprecip1(len, nd+1)
-  REAL upwd1(len, nd)
-  REAL dnwd1(len, nd)
-  REAL dnwd01(len, nd)
-  REAL qcondc1(len, nd) ! cld
-  REAL wd1(len) ! gust
-  REAL cape1(len)
-  REAL cin1(len)
-  REAL tvp1(len, nd)
+  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecip1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd01
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1         ! 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
 
 !AC!
@@ -224,26 +235,27 @@
 !!      real da(len,nd),phi(len,nd,nd)
 !AC!
-  REAL ftd1(len, nd)
-  REAL fqd1(len, nd)
-  REAL Plim11(len)
-  REAL Plim21(len)
-  REAL asupmax1(len, nd)
-  REAL supmax01(len)
-  REAL asupmaxmin1(len)
-  INTEGER lalim_conv(len)
-  REAL qtc1(len, nd)         ! cld
-  REAL sigt1(len, nd)        ! cld
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqd1
+  REAL, DIMENSION (len), INTENT (OUT)                :: Plim11
+  REAL, DIMENSION (len), INTENT (OUT)                :: Plim21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1
+  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01
+  REAL, DIMENSION (len), INTENT (OUT)                :: asupmaxmin1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1            ! cld
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sigt1           ! cld
 
 ! RomP >>>
-  REAL wdtrainA1(len, nd), wdtrainM1(len, nd)
-  REAL da1(len, nd), phi1(len, nd, nd), mp1(len, nd)
-  REAL epmlmMm1(len, nd, nd), eplaMm1(len, nd)
-  REAL evap1(len, nd), ep1(len, nd)
-  REAL sigij1(len, nd, nd), elij1(len, nd, nd)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1, mp1
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplaMm1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1, ep1
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1, elij1
 !JYG,RL
-  REAL wghti1(len, nd) ! final weight of the feeding layers
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti1      ! final weight of the feeding layers
 !JYG,RL
-  REAL phi21(len, nd, nd)
-  REAL d1a1(len, nd), dam1(len, nd)
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1
 ! RomP <<<
 
@@ -388,4 +400,5 @@
 !$OMP THREADPRIVATE(debut)
 
+  REAL coef_convective(len)   ! = 1 for convective points, = 0 otherwise
   REAL tnk1(klon)
   REAL thnk1(klon)
@@ -426,8 +439,9 @@
 ! (local) compressed fields:
 
-  INTEGER nloc
-! parameter (nloc=klon) ! pour l'instant
 
   INTEGER idcum(nloc)
+!jyg<
+  LOGICAL compress    ! True if compression occurs
+!>jyg
   INTEGER iflag(nloc), nk(nloc), icb(nloc)
   INTEGER nent(nloc, klev)
@@ -480,6 +494,7 @@
   REAL fu(nloc, klev), fv(nloc, klev)
   REAL upwd(nloc, klev), dnwd(nloc, klev), dnwd0(nloc, klev)
-  REAL ma(nloc, klev), mip(nloc, klev), tls(nloc, klev)
-  REAL tps(nloc, klev), qprime(nloc), tprime(nloc)
+  REAL ma(nloc, klev), mip(nloc, klev)
+!!  REAL tls(nloc, klev), tps(nloc, klev)                 ! unused . jyg
+  REAL qprime(nloc), tprime(nloc)
   REAL precip(nloc)
 ! real Vprecip(nloc,klev)
@@ -547,5 +562,5 @@
 
   IF (iflag_con==3) THEN
-    CALL cv3_param(nd, delt)
+    CALL cv3_param(nd, k_upper, delt)
 
   END IF
@@ -682,5 +697,5 @@
 !   p2feed1(i)=ph1(i,3)
 !testCR: on prend la couche alim des thermiques
-!   p2feed1(i)=ph1(i,lalim_conv(i)+1)
+!   p2feed1(i)=ph1(i,lalim_conv1(i)+1)
 !   print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
   END DO
@@ -762,7 +777,12 @@
 ! =====================================================================
 
+!  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
@@ -782,5 +802,18 @@
 ! print*,'ncum tv1 ',ncum,tv1
 ! print*,'tvp1 ',tvp1
-      CALL cv3a_compress(len, nloc, ncum, nd, ntra, &
+!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
+      CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
                          iflag1, nk1, icb1, icbs1, &
                          plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
@@ -837,5 +870,4 @@
                          inb, tp, tvp, clw, hp, ep, sigp, buoy, &
                          frac)
-
     END IF
 
@@ -897,5 +929,4 @@
                            Plim1, plim2, asupmax, supmax0, &
                            asupmaxmin, cbmf, plfc, wbeff)
-
         if (prt_level >= 10) &
              PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1)
@@ -993,5 +1024,6 @@
                      iflag, precip, vprecip, ft, fq, fu, fv, ftra, &
                      cbmf, upwd, dnwd, dnwd0, ma, mip, &
-                     tls, tps, qcondc, wd, &
+!!                     tls, tps, &                            ! useless . jyg
+                     qcondc, wd, &
                      ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
     END IF
@@ -1035,5 +1067,5 @@
 
     IF (iflag_con==3) THEN
-      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, &
+      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
                            iflag, icb, inb, &
                            precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
@@ -1078,6 +1110,14 @@
   END IF ! ncum>0
 
+!
+! 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_compress -> '
+    PRINT *, ' cv_uncompress -> '
     debut = .FALSE.
   END IF  !(debut) THEN
Index: LMDZ5/branches/testing/libf/phylmd/cvltr_scav.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/cvltr_scav.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/cvltr_scav.F90	(revision 2298)
@@ -122,22 +122,24 @@
   real                           :: conservMA
 
-  ! ======================================================
-  ! 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 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
@@ -237,4 +239,24 @@
   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
Index: LMDZ5/branches/testing/libf/phylmd/declare_STDlev.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/declare_STDlev.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/declare_STDlev.h	(revision 2298)
@@ -57,5 +57,5 @@
       REAL zx_tmp_fiNC(klon,nlevSTD)
 
-      REAL missing_val
+!     REAL missing_val
       REAL, SAVE :: freq_moyNMC(nout)
 !$OMP THREADPRIVATE(freq_moyNMC)
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1DUTILS.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1DUTILS.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1DUTILS.h	(revision 2298)
@@ -0,0 +1,4448 @@
+#include "conf_gcm.F90"
+#include "q_sat.F"
+
+!
+! $Id: conf_unicol.F 1279 2010-08-04 17:20:56Z lahellec $
+!
+!
+!
+      SUBROUTINE conf_unicol
+!
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom
+#endif
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     Auteurs :   A. Lahellec  .
+!
+!   Declarations :
+!   --------------
+
+#include "compar1d.h"
+#include "flux_arp.h"
+#include "tsoilnudge.h"
+#include "fcg_gcssold.h"
+#include "fcg_racmo.h"
+#include "iniprint.h"
+!
+!
+!   local:
+!   ------
+
+!      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      
+!
+!  -------------------------------------------------------------------
+!
+!      .........    Initilisation parametres du lmdz1D      ..........
+!
+!---------------------------------------------------------------------
+!   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(lunout,FILE='lmdz.out')
+      ENDIF
+
+!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('prt_level',prt_level)
+
+!-----------------------------------------------------------------------
+!  Parametres de controle du run:
+!-----------------------------------------------------------------------
+
+!Config  Key  = restart
+!Config  Desc = on repart des startphy et start1dyn
+!Config  Def  = false
+!Config  Help = les fichiers restart doivent etre renomme en start
+       restart =.false.
+       CALL getin('restart',restart)
+
+!Config  Key  = forcing_type
+!Config  Desc = defines the way the SCM is forced:
+!Config  Def  = 0
+!!Config  Help = 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)
+!         = 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)
+!         = 2 ==> forcing_toga = .true.
+!             initial profiles from TOGA-COARE IFA files 
+!             LS convergence and SST imposed from TOGA-COARE IFA files 
+!         = 3 ==> forcing_GCM2SCM = .true.
+!             initial profiles from the GCM output
+!             LS convergence imposed from the GCM output
+!         = 4 ==> forcing_twpi = .true.
+!             initial profiles from TWPICE nc files 
+!             LS convergence and SST imposed from TWPICE nc files 
+!         = 5 ==> forcing_rico = .true.
+!             initial profiles from RICO idealized
+!             LS convergence imposed from  RICO (cst) 
+!         = 6 ==> forcing_amma = .true.
+!         = 10 ==> forcing_case = .true.
+!             initial profiles from case.nc file 
+!         = 40 ==> forcing_GCSSold = .true.
+!             initial profile from GCSS file
+!             LS convergence imposed from GCSS file
+!         = 50 ==> forcing_fire = .true.
+!         = 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
+!         = 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
+!         = 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
+!
+       forcing_type = 0
+       CALL getin('forcing_type',forcing_type)
+         imp_fcg_gcssold   = .false.
+         ts_fcg_gcssold    = .false.  
+         Tp_fcg_gcssold    = .false.  
+         Tp_ini_gcssold    = .false.  
+         xTurb_fcg_gcssold = .false. 
+        IF (forcing_type .eq.40) THEN
+          CALL getin('imp_fcg',imp_fcg_gcssold)
+          CALL getin('ts_fcg',ts_fcg_gcssold)
+          CALL getin('tp_fcg',Tp_fcg_gcssold)
+          CALL getin('tp_ini',Tp_ini_gcssold)
+          CALL getin('turb_fcg',xTurb_fcg_gcssold)
+        ENDIF
+
+!Paramètres de forçage
+!Config  Key  = tend_t
+!Config  Desc = forcage ou non par advection de T
+!Config  Def  = false
+!Config  Help = forcage ou non par advection de T
+       tend_t =0
+       CALL getin('tend_t',tend_t)
+
+!Config  Key  = tend_q
+!Config  Desc = forcage ou non par advection de q
+!Config  Def  = false
+!Config  Help = forcage ou non par advection de q
+       tend_q =0
+       CALL getin('tend_q',tend_q)
+
+!Config  Key  = tend_u
+!Config  Desc = forcage ou non par advection de u
+!Config  Def  = false
+!Config  Help = forcage ou non par advection de u
+       tend_u =0
+       CALL getin('tend_u',tend_u)
+
+!Config  Key  = tend_v
+!Config  Desc = forcage ou non par advection de v
+!Config  Def  = false
+!Config  Help = forcage ou non par advection de v
+       tend_v =0
+       CALL getin('tend_v',tend_v)
+
+!Config  Key  = tend_w
+!Config  Desc = forcage ou non par vitesse verticale
+!Config  Def  = false
+!Config  Help = forcage ou non par vitesse verticale
+       tend_w =0
+       CALL getin('tend_w',tend_w)
+
+!Config  Key  = tend_rayo
+!Config  Desc = forcage ou non par dtrad
+!Config  Def  = false
+!Config  Help = forcage ou non par dtrad
+       tend_rayo =0
+       CALL getin('tend_rayo',tend_rayo)
+
+
+!Config  Key  = nudge_t
+!Config  Desc = constante de nudging de T
+!Config  Def  = false
+!Config  Help = constante de nudging de T
+       nudge_t =0.
+       CALL getin('nudge_t',nudge_t)
+
+!Config  Key  = nudge_q
+!Config  Desc = constante de nudging de q
+!Config  Def  = false
+!Config  Help = constante de nudging de q
+       nudge_q =0.
+       CALL getin('nudge_q',nudge_q)
+
+!Config  Key  = nudge_u
+!Config  Desc = constante de nudging de u
+!Config  Def  = false
+!Config  Help = constante de nudging de u
+       nudge_u =0.
+       CALL getin('nudge_u',nudge_u)
+
+!Config  Key  = nudge_v
+!Config  Desc = constante de nudging de v
+!Config  Def  = false
+!Config  Help = constante de nudging de v
+       nudge_v =0.
+       CALL getin('nudge_v',nudge_v)
+
+!Config  Key  = nudge_w
+!Config  Desc = constante de nudging de w
+!Config  Def  = false
+!Config  Help = constante de nudging de w
+       nudge_w =0.
+       CALL getin('nudge_w',nudge_w)
+
+
+!Config  Key  = iflag_nudge
+!Config  Desc = atmospheric nudging ttype (decimal code)
+!Config  Def  = 0
+!Config  Help = 0 ==> no nudging
+!  If digit number n of iflag_nudge is set, then nudging of type n is on
+!  If digit number n of iflag_nudge is not set, then nudging of type n is off
+!   (digits are numbered from the right)
+       iflag_nudge = 0
+       CALL getin('iflag_nudge',iflag_nudge)
+
+!Config  Key  = ok_flux_surf
+!Config  Desc = forcage ou non par les flux de surface
+!Config  Def  = false
+!Config  Help = forcage ou non par les flux de surface
+       ok_flux_surf =.false.
+       CALL getin('ok_flux_surf',ok_flux_surf)
+
+!Config  Key  = ok_prescr_ust
+!Config  Desc = ustar impose ou non
+!Config  Def  = false
+!Config  Help = ustar impose ou non
+       ok_prescr_ust = .false.
+       CALL getin('ok_prescr_ust',ok_prescr_ust)
+
+!Config  Key  = ok_old_disvert
+!Config  Desc = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
+!Config  Def  = false
+!Config  Help = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
+       ok_old_disvert = .FALSE.
+       CALL getin('ok_old_disvert',ok_old_disvert)
+
+!Config  Key  = time_ini
+!Config  Desc = meaningless in this  case
+!Config  Def  = 0.
+!Config  Help = 
+       tsurf = 0.
+       CALL getin('time_ini',time_ini)
+
+!Config  Key  = rlat et rlon
+!Config  Desc = latitude et longitude
+!Config  Def  = 0.0  0.0
+!Config  Help = fixe la position de la colonne
+       xlat = 0.
+       xlon = 0.
+       CALL getin('rlat',xlat)
+       CALL getin('rlon',xlon)
+
+!Config  Key  = airephy
+!Config  Desc = Grid cell area
+!Config  Def  = 1.e11
+!Config  Help = 
+       airefi = 1.e11
+       CALL getin('airephy',airefi)
+
+!Config  Key  = nat_surf
+!Config  Desc = surface type
+!Config  Def  = 0 (ocean)
+!Config  Help = 0=ocean,1=land,2=glacier,3=banquise
+       nat_surf = 0.
+       CALL getin('nat_surf',nat_surf)
+
+!Config  Key  = tsurf
+!Config  Desc = surface temperature
+!Config  Def  = 290.
+!Config  Help = not used if type_ts_forcing=1 in lmdz1d.F
+       tsurf = 290.
+       CALL getin('tsurf',tsurf)
+
+!Config  Key  = psurf
+!Config  Desc = surface pressure
+!Config  Def  = 102400.
+!Config  Help = 
+       psurf = 102400.
+       CALL getin('psurf',psurf)
+
+!Config  Key  = zsurf
+!Config  Desc = surface altitude
+!Config  Def  = 0.
+!Config  Help = 
+       zsurf = 0.
+       CALL getin('zsurf',zsurf)
+
+!Config  Key  = rugos
+!Config  Desc = coefficient de frottement
+!Config  Def  = 0.0001
+!Config  Help = calcul du Cdrag
+       rugos = 0.0001
+       CALL getin('rugos',rugos)
+
+!Config  Key  = wtsurf et wqsurf
+!Config  Desc = ???
+!Config  Def  = 0.0 0.0
+!Config  Help = 
+       wtsurf = 0.0
+       wqsurf = 0.0
+       CALL getin('wtsurf',wtsurf)
+       CALL getin('wqsurf',wqsurf)
+
+!Config  Key  = albedo
+!Config  Desc = albedo
+!Config  Def  = 0.09
+!Config  Help = 
+       albedo = 0.09
+       CALL getin('albedo',albedo)
+
+!Config  Key  = agesno
+!Config  Desc = age de la neige
+!Config  Def  = 30.0
+!Config  Help = 
+       xagesno = 30.0
+       CALL getin('agesno',xagesno)
+
+!Config  Key  = restart_runoff
+!Config  Desc = age de la neige
+!Config  Def  = 30.0
+!Config  Help = 
+       restart_runoff = 0.0
+       CALL getin('restart_runoff',restart_runoff)
+
+!Config  Key  = qsolinp
+!Config  Desc = initial bucket water content (kg/m2) when land (5std)
+!Config  Def  = 30.0
+!Config  Help = 
+       qsolinp = 1.
+       CALL getin('qsolinp',qsolinp)
+
+!Config  Key  = zpicinp
+!Config  Desc = denivellation orographie
+!Config  Def  = 300.
+!Config  Help =  input brise
+       zpicinp = 300.
+       CALL getin('zpicinp',zpicinp)
+!Config key = nudge_tsoil
+!Config  Desc = activation of soil temperature nudging
+!Config  Def  = .FALSE.
+!Config  Help = ...
+
+       nudge_tsoil=.FALSE.
+       CALL getin('nudge_tsoil',nudge_tsoil)
+
+!Config key = isoil_nudge
+!Config  Desc = level number where soil temperature is nudged
+!Config  Def  = 3
+!Config  Help = ...
+
+       isoil_nudge=3
+       CALL getin('isoil_nudge',isoil_nudge)
+
+!Config key = Tsoil_nudge
+!Config  Desc = target temperature for tsoil(isoil_nudge)
+!Config  Def  = 300.
+!Config  Help = ...
+
+       Tsoil_nudge=300.
+       CALL getin('Tsoil_nudge',Tsoil_nudge)
+
+!Config key = tau_soil_nudge
+!Config  Desc = nudging relaxation time for tsoil
+!Config  Def  = 3600.
+!Config  Help = ...
+
+       tau_soil_nudge=3600.
+       CALL getin('tau_soil_nudge',tau_soil_nudge)
+
+
+
+
+      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
+      write(lunout,*)' Configuration des parametres du gcm1D: '
+      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
+      write(lunout,*)' restart = ', restart
+      write(lunout,*)' forcing_type = ', forcing_type
+      write(lunout,*)' time_ini = ', time_ini
+      write(lunout,*)' rlat = ', xlat
+      write(lunout,*)' rlon = ', xlon
+      write(lunout,*)' airephy = ', airefi
+      write(lunout,*)' nat_surf = ', nat_surf
+      write(lunout,*)' tsurf = ', tsurf
+      write(lunout,*)' psurf = ', psurf
+      write(lunout,*)' zsurf = ', zsurf
+      write(lunout,*)' rugos = ', rugos
+      write(lunout,*)' wtsurf = ', wtsurf
+      write(lunout,*)' wqsurf = ', wqsurf
+      write(lunout,*)' albedo = ', albedo
+      write(lunout,*)' xagesno = ', xagesno
+      write(lunout,*)' restart_runoff = ', restart_runoff
+      write(lunout,*)' qsolinp = ', qsolinp
+      write(lunout,*)' zpicinp = ', zpicinp
+      write(lunout,*)' nudge_tsoil = ', nudge_tsoil
+      write(lunout,*)' isoil_nudge = ', isoil_nudge
+      write(lunout,*)' Tsoil_nudge = ', Tsoil_nudge
+      write(lunout,*)' tau_soil_nudge = ', tau_soil_nudge
+      IF (forcing_type .eq.40) THEN
+        write(lunout,*) '--- Forcing type GCSS Old --- with:'
+        write(lunout,*)'imp_fcg',imp_fcg_gcssold
+        write(lunout,*)'ts_fcg',ts_fcg_gcssold
+        write(lunout,*)'tp_fcg',Tp_fcg_gcssold
+        write(lunout,*)'tp_ini',Tp_ini_gcssold
+        write(lunout,*)'xturb_fcg',xTurb_fcg_gcssold
+      ENDIF
+
+      write(lunout,*)' +++++++++++++++++++++++++++++++++++++++'
+      write(lunout,*)
+!
+      RETURN
+      END
+!
+! $Id: dyn1deta0.F 1279 2010/07/30 A Lahellec$
+!
+!
+      SUBROUTINE dyn1deta0(fichnom,plev,play,phi,phis,presnivs,                 &
+     &                          ucov,vcov,temp,q,omega2)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE phys_state_var_mod
+      USE iostart
+      USE write_field_phy
+      USE infotrac
+      use control_mod
+
+      IMPLICIT NONE
+!=======================================================
+! Ecriture du fichier de redemarrage sous format NetCDF
+!=======================================================
+!   Declarations:
+!   -------------
+      include "dimensions.h"
+      include "comconst.h"
+      include "temps.h"
+!!#include "control.h"
+      include "logic.h"
+      include "netcdf.inc"
+
+!   Arguments:
+!   ----------
+      CHARACTER*(*) fichnom
+!Al1 plev tronque pour .nc mais plev(klev+1):=0
+      real :: plev(klon,klev+1),play (klon,klev),phi(klon,klev)
+      real :: presnivs(klon,klev)
+      real :: ucov(klon,klev),vcov(klon,klev),temp(klon,klev)
+      real :: q(klon,klev,nqtot),omega2(klon,klev)
+!      real :: ug(klev),vg(klev),fcoriolis
+      real :: phis(klon) 
+
+!   Variables locales pour NetCDF:
+!   ------------------------------
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*4 nmq(nqtot)
+      character*12 modname
+      character*80 abort_message
+      LOGICAL found
+
+      modname = 'dyn1deta0 : '
+      nmq(1)="vap"
+      nmq(2)="cond"
+      do iq=3,nqtot
+        write(nmq(iq),'("tra",i1)') iq-2
+      enddo
+      print*,'in dyn1deta0 ',fichnom,klon,klev,nqtot
+      CALL open_startphy(fichnom)
+      print*,'after open startphy ',fichnom,nmq
+
+!
+! Lecture des parametres de controle:
+!
+      CALL get_var("controle",tab_cntrl)
+       
+
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      day_ref    = tab_cntrl(4)
+      annee_ref  = tab_cntrl(5)
+!      rad        = tab_cntrl(6)
+!      omeg       = tab_cntrl(7)
+!      g          = tab_cntrl(8)
+!      cpp        = tab_cntrl(9)
+!      kappa      = tab_cntrl(10)
+!      daysec     = tab_cntrl(11)
+!      dtvr       = tab_cntrl(12)
+!      etot0      = tab_cntrl(13)
+!      ptot0      = tab_cntrl(14)
+!      ztot0      = tab_cntrl(15)
+!      stot0      = tab_cntrl(16)
+!      ang0       = tab_cntrl(17)
+!      pa         = tab_cntrl(18)
+!      preff      = tab_cntrl(19)
+!
+!      clon       = tab_cntrl(20)
+!      clat       = tab_cntrl(21)
+!      grossismx  = tab_cntrl(22)
+!      grossismy  = tab_cntrl(23)
+!
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  =.true.
+!        dzoomx   = tab_cntrl(25)
+!        dzoomy   = tab_cntrl(26)
+!        taux     = tab_cntrl(28)
+!        tauy     = tab_cntrl(29)
+      ELSE
+        fxyhypb = .false.
+        ysinus  = .false.
+        IF( tab_cntrl(27).EQ.1. ) ysinus =.true. 
+      ENDIF
+
+      day_ini = tab_cntrl(30)
+      itau_dyn = tab_cntrl(31)
+!   .................................................................
+!
+!
+!      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+!Al1
+       Print*,'day_ref,annee_ref,day_ini,itau_dyn',                         &
+     &              day_ref,annee_ref,day_ini,itau_dyn
+
+!  Lecture des champs
+!
+      CALL get_field("play",play,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <Play> est absent'
+      CALL get_field("phi",phi,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <Phi> est absent'
+      CALL get_field("phis",phis,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <Phis> est absent'
+      CALL get_field("presnivs",presnivs,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <Presnivs> est absent'
+      CALL get_field("ucov",ucov,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <ucov> est absent'
+      CALL get_field("vcov",vcov,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <vcov> est absent'
+      CALL get_field("temp",temp,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <temp> est absent'
+      CALL get_field("omega2",omega2,found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <omega2> est absent'
+      plev(1,klev+1)=0.
+      CALL get_field("plev",plev(:,1:klev),found)
+      IF (.NOT. found) PRINT*, modname//'Le champ <Plev> est absent'
+
+      Do iq=1,nqtot
+        CALL get_field("q"//nmq(iq),q(:,:,iq),found)
+        IF (.NOT.found)PRINT*, modname//'Le champ <q'//nmq//'> est absent'
+      EndDo
+
+      CALL close_startphy
+      print*,' close startphy',fichnom,play(1,1),play(1,klev),temp(1,klev)
+!
+      RETURN
+      END
+!
+! $Id: dyn1dredem.F 1279 2010/07/29 A Lahellec$
+!
+!
+      SUBROUTINE dyn1dredem(fichnom,plev,play,phi,phis,presnivs,           &
+     &                          ucov,vcov,temp,q,omega2)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE phys_state_var_mod
+      USE iostart
+      USE infotrac
+      use control_mod
+
+      IMPLICIT NONE
+!=======================================================
+! Ecriture du fichier de redemarrage sous format NetCDF
+!=======================================================
+!   Declarations:
+!   -------------
+      include "dimensions.h"
+      include "comconst.h"
+      include "temps.h"
+!!#include "control.h"
+      include "logic.h"
+      include "netcdf.inc"
+
+!   Arguments:
+!   ----------
+      CHARACTER*(*) fichnom
+!Al1 plev tronque pour .nc mais plev(klev+1):=0
+      real :: plev(klon,klev),play (klon,klev),phi(klon,klev)
+      real :: presnivs(klon,klev)
+      real :: ucov(klon,klev),vcov(klon,klev),temp(klon,klev)
+      real :: q(klon,klev,nqtot)
+      real :: omega2(klon,klev),rho(klon,klev+1)
+!      real :: ug(klev),vg(klev),fcoriolis
+      real :: phis(klon) 
+
+!   Variables locales pour NetCDF:
+!   ------------------------------
+      INTEGER nid
+      INTEGER ierr
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*4 nmq(nqtot)
+      character*20 modname
+      character*80 abort_message
+!
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      CALL open_restartphy(fichnom)
+      print*,'redm1 ',fichnom,klon,klev,nqtot
+      nmq(1)="vap"
+      nmq(2)="cond"
+      nmq(3)="tra1"
+      nmq(4)="tra2"
+
+      modname = 'dyn1dredem'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="Pb. d ouverture "//fichnom
+         CALL abort_gcm('Modele 1D',abort_message,1)
+      ENDIF
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = FLOAT(iim)
+       tab_cntrl(2)  = FLOAT(jjm)
+       tab_cntrl(3)  = FLOAT(llm)
+       tab_cntrl(4)  = FLOAT(day_ref)
+       tab_cntrl(5)  = FLOAT(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
+!
+!    .....    parametres  pour le 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.
+      ENDIF
+!Al1 iday_end -> day_end
+       tab_cntrl(30) = FLOAT(day_end)
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+!
+      CALL put_var("controle","Param. de controle Dyn1D",tab_cntrl)
+!
+
+!  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+
+!  Ecriture des champs
+!
+      CALL put_field("plev","p interfaces sauf la nulle",plev)
+      CALL put_field("play","",play)
+      CALL put_field("phi","geopotentielle",phi)
+      CALL put_field("phis","geopotentiell de surface",phis)
+      CALL put_field("presnivs","",presnivs)
+      CALL put_field("ucov","",ucov)
+      CALL put_field("vcov","",vcov)
+      CALL put_field("temp","",temp)
+      CALL put_field("omega2","",omega2)
+
+      Do iq=1,nqtot
+        CALL put_field("q"//nmq(iq),"eau vap ou condens et traceurs",           &
+     &                                                      q(:,:,iq))
+      EndDo
+      CALL close_restartphy
+
+!
+      RETURN
+      END
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      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 i,j,ifield,ig
+ 
+!-----------------------------------------------------------------------
+!   calcul:
+!   -------
+ 
+      DO ifield=1,nfield
+!   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+ 
+!   traitement des point normaux
+         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
+ 
+      RETURN
+      END
+ 
+ 
+
+      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
+!     call histclo(2)
+!     call histclo(3)
+!     call histclo(4)
+!     call histclo(5)
+      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
+      REAL FUNCTION fq_sat(kelvin, millibar)
+!
+      IMPLICIT none
+!======================================================================
+! Autheur(s): Z.X. Li (LMD/CNRS)
+! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+!======================================================================
+! Arguments:
+! kelvin---input-R: temperature en Kelvin
+! millibar--input-R: pression en mb
+!
+! fq_sat----output-R: vapeur d'eau saturante en kg/kg
+!======================================================================
+!
+      REAL kelvin, millibar
+!
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+!
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+!
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+!
+      REAL rtt
+      PARAMETER (rtt=273.16)
+!
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+!
+      REAL zqsat
+      REAL temp, pres
+!     ------------------------------------------------------------------
+!
+!
+      temp = kelvin
+      pres = millibar * 100.0
+!      write(*,*)'kelvin,millibar=',kelvin,millibar
+!      write(*,*)'temp,pres=',temp,pres
+!
+      IF (temp .LE. rtt) THEN
+         r3es = r3ies
+         r4es = r4ies
+      ELSE
+         r3es = r3les
+         r4es = r4les
+      ENDIF
+!
+      zqsat=r2es/pres * EXP ( r3es*(temp-rtt) / (temp-r4es) )
+      zqsat=MIN(0.5,ZQSAT)
+      zqsat=zqsat/(1.-retv  *zqsat)
+!
+      fq_sat = zqsat
+!
+      RETURN
+      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
+ 
+      SUBROUTINE disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+ 
+!    Ancienne version disvert dont on a modifie nom pour utiliser
+!    le disvert de dyn3d (qui permet d'utiliser grille avec ab,bp imposes)
+!    (MPL 18092012)
+!
+!    Auteur :  P. Le Van .
+!
+      IMPLICIT NONE
+ 
+      include "dimensions.h"
+      include "paramet.h"
+!
+!=======================================================================
+!
+!
+!    s = sigma ** kappa   :  coordonnee  verticale
+!    dsig(l)            : epaisseur de la couche l ds la coord.  s
+!    sig(l)             : sigma a l'interface des couches l et l-1
+!    ds(l)              : distance entre les couches l et l-1 en coord.s
+!
+!=======================================================================
+!
+      REAL pa,preff
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL presnivs(llm)
+!
+!   declarations:
+!   -------------
+!
+      REAL sig(llm+1),dsig(llm)
+!
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+ 
+!-----------------------------------------------------------------------
+!
+      pi=2.*ASIN(1.)
+ 
+      OPEN(99,file='sigma.def',status='old',form='formatted',                   &
+     &   iostat=ierr)
+ 
+!-----------------------------------------------------------------------
+!   cas 1 on lit les options dans sigma.def:
+!   ----------------------------------------
+ 
+      IF (ierr.eq.0) THEN
+ 
+      print*,'WARNING!!! on lit les options dans sigma.def'
+      READ(99,*) deltaz
+      READ(99,*) h
+      READ(99,*) beta
+      READ(99,*) gama
+      READ(99,*) delta
+      READ(99,*) np
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+!
+ 
+       DO 1  l = 1, llm
+       dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*                    &
+     &          ( (tanh(gama*l)/tanh(gama*llm))**np +                      &
+     &            (1.-l/FLOAT(llm))*delta )
+   1   CONTINUE
+ 
+       sig(1)=1.
+       DO 101 l=1,llm-1
+          sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
+101    CONTINUE
+       sig(llm+1)=0.
+ 
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+!
+ 
+      ELSE
+!-----------------------------------------------------------------------
+!   cas 2 ancienne discretisation (LMD5...):
+!   ----------------------------------------
+ 
+      PRINT*,'WARNING!!! Ancienne discretisation verticale'
+ 
+      h=7.
+      snorm  = 0.
+      DO l = 1, llm
+         x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
+         dsig(l) = 1.0 + 7.0 * SIN(x)**2
+         snorm = snorm + dsig(l)
+      ENDDO
+      snorm = 1./snorm
+      DO l = 1, llm
+         dsig(l) = dsig(l)*snorm
+      ENDDO
+      sig(llm+1) = 0.
+      DO l = llm, 1, -1
+         sig(l) = sig(l+1) + dsig(l)
+      ENDDO
+ 
+      ENDIF
+ 
+ 
+      DO l=1,llm
+        nivsigs(l) = FLOAT(l)
+      ENDDO
+ 
+      DO l=1,llmp1
+        nivsig(l)= FLOAT(l)
+      ENDDO
+ 
+!
+!    ....  Calculs  de ap(l) et de bp(l)  ....
+!    .........................................
+!
+!
+!   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+!
+ 
+      bp(llmp1) =   0.
+ 
+      DO l = 1, llm
+!c
+!cc    ap(l) = 0.
+!cc    bp(l) = sig(l)
+ 
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+!
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+ 
+      PRINT *,' BP '
+      PRINT *,  bp
+      PRINT *,' AP '
+      PRINT *,  ap
+ 
+      DO l = 1, llm
+       dpres(l) = bp(l) - bp(l+1)
+       presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+      ENDDO
+ 
+      PRINT *,' PRESNIVS '
+      PRINT *,presnivs
+ 
+      RETURN
+      END
+
+!======================================================================
+       SUBROUTINE read_tsurf1d(knon,sst_out)
+
+! This subroutine specifies the surface temperature to be used in 1D simulations
+
+      USE dimphy, ONLY : klon
+
+      INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
+      REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out  ! tsurf used to force the single-column model
+
+       INTEGER :: i
+! COMMON defined in lmdz1d.F:
+       real ts_cur
+       common /sst_forcing/ts_cur
+
+       DO i = 1, knon
+        sst_out(i) = ts_cur
+       ENDDO
+
+      END SUBROUTINE read_tsurf1d
+
+!===============================================================
+      subroutine advect_vert(llm,w,dt,q,plev)
+!===============================================================
+!   Schema amont pour l'advection verticale en 1D
+!   w est la vitesse verticale dp/dt en Pa/s
+!   Traitement en volumes finis 
+!   d / dt ( zm q ) = delta_z ( omega q )
+!   d / dt ( zm ) = delta_z ( omega )
+!   avec zm = delta_z ( p )
+!   si * designe la valeur au pas de temps t+dt
+!   zm*(l) q*(l) - zm(l) q(l) = w(l+1) q(l+1) - w(l) q(l)
+!   zm*(l) -zm(l) = w(l+1) - w(l)
+!   avec w=omega * dt
+!---------------------------------------------------------------
+      implicit none
+! arguments
+      integer llm
+      real w(llm+1),q(llm),plev(llm+1),dt
+
+! local
+      integer l
+      real zwq(llm+1),zm(llm+1),zw(llm+1)
+      real qold
+
+!---------------------------------------------------------------
+
+      do l=1,llm
+         zw(l)=dt*w(l)
+         zm(l)=plev(l)-plev(l+1)
+         zwq(l)=q(l)*zw(l)
+      enddo
+      zwq(llm+1)=0.
+      zw(llm+1)=0.
+ 
+      do l=1,llm
+         qold=q(l)
+         q(l)=(q(l)*zm(l)+zwq(l+1)-zwq(l))/(zm(l)+zw(l+1)-zw(l))
+         print*,'ADV Q ',zm(l),zw(l),zwq(l),qold,q(l)
+      enddo
+
+ 
+      return
+      end
+
+!===============================================================
+
+
+       SUBROUTINE advect_va(llm,omega,d_t_va,d_q_va,d_u_va,d_v_va,              &
+     &                q,temp,u,v,play)
+!itlmd 
+!----------------------------------------------------------------------
+!   Calcul de l'advection verticale (ascendance et subsidence) de 
+!   température et d'humidité. Hypothèse : ce qui rentre de l'extérieur
+!   a les mêmes caractéristiques que l'air de la colonne 1D (WTG) ou 
+!   sans WTG rajouter une advection horizontale 
+!----------------------------------------------------------------------  
+        implicit none
+#include "YOMCST.h"
+!        argument
+        integer llm
+        real  omega(llm+1),d_t_va(llm), d_q_va(llm,3)
+        real  d_u_va(llm), d_v_va(llm)
+        real  q(llm,3),temp(llm)
+        real  u(llm),v(llm)
+        real  play(llm)
+! interne
+        integer l
+        real alpha,omgdown,omgup
+
+      do l= 1,llm
+       if(l.eq.1) then
+!si omgup pour la couche 1, alors tendance nulle
+        omgdown=max(omega(2),0.0)
+        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
+        d_t_va(l)= alpha*(omgdown)-omgdown*(temp(l)-temp(l+1))             &
+     &       /(play(l)-play(l+1))
+
+        d_q_va(l,:)= -omgdown*(q(l,:)-q(l+1,:))/(play(l)-play(l+1))              
+
+        d_u_va(l)= -omgdown*(u(l)-u(l+1))/(play(l)-play(l+1))              
+        d_v_va(l)= -omgdown*(v(l)-v(l+1))/(play(l)-play(l+1))              
+
+        
+       elseif(l.eq.llm) then
+        omgup=min(omega(l),0.0)
+        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
+        d_t_va(l)= alpha*(omgup)-                                          &
+
+!bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
+     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-play(l))
+        d_q_va(l,:)= -omgup*(q(l-1,:)-q(l,:))/(play(l-1)-play(l))
+        d_u_va(l)= -omgup*(u(l-1)-u(l))/(play(l-1)-play(l))
+        d_v_va(l)= -omgup*(v(l-1)-v(l))/(play(l-1)-play(l))
+       
+       else
+        omgup=min(omega(l),0.0)
+        omgdown=max(omega(l+1),0.0)
+        alpha = rkappa*temp(l)*(1.+q(l,1)*rv/rd)/(play(l)*(1.+q(l,1)))
+        d_t_va(l)= alpha*(omgup+omgdown)-omgdown*(temp(l)-temp(l+1))       &
+     &              /(play(l)-play(l+1))-                                  &
+!bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
+     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-play(l))
+!      print*, '  ??? '
+
+        d_q_va(l,:)= -omgdown*(q(l,:)-q(l+1,:))                            &
+     &              /(play(l)-play(l+1))-                                  &
+     &              omgup*(q(l-1,:)-q(l,:))/(play(l-1)-play(l)) 
+        d_u_va(l)= -omgdown*(u(l)-u(l+1))                                  &
+     &              /(play(l)-play(l+1))-                                  &
+     &              omgup*(u(l-1)-u(l))/(play(l-1)-play(l)) 
+        d_v_va(l)= -omgdown*(v(l)-v(l+1))                                  &
+     &              /(play(l)-play(l+1))-                                  &
+     &              omgup*(v(l-1)-v(l))/(play(l-1)-play(l))
+       
+      endif
+         
+      enddo
+!fin itlmd
+        return
+        end
+!       SUBROUTINE lstendH(llm,omega,d_t_va,d_q_va,d_u_va,d_v_va,
+       SUBROUTINE lstendH(llm,nqtot,omega,d_t_va,d_q_va,                        &
+     &                q,temp,u,v,play)
+!itlmd 
+!----------------------------------------------------------------------
+!   Calcul de l'advection verticale (ascendance et subsidence) de 
+!   température et d'humidité. Hypothèse : ce qui rentre de l'extérieur
+!   a les mêmes caractéristiques que l'air de la colonne 1D (WTG) ou 
+!   sans WTG rajouter une advection horizontale 
+!----------------------------------------------------------------------  
+        implicit none
+#include "YOMCST.h"
+!        argument
+        integer llm,nqtot
+        real  omega(llm+1),d_t_va(llm), d_q_va(llm,nqtot)
+!        real  d_u_va(llm), d_v_va(llm)
+        real  q(llm,nqtot),temp(llm)
+        real  u(llm),v(llm)
+        real  play(llm)
+        real cor(llm)
+!        real dph(llm),dudp(llm),dvdp(llm),dqdp(llm),dtdp(llm)
+        real dph(llm),dqdp(llm),dtdp(llm)
+! interne
+        integer k
+        real omdn,omup
+
+!        dudp=0.
+!        dvdp=0.
+        dqdp=0.
+        dtdp=0.
+!        d_u_va=0.
+!        d_v_va=0.
+
+      cor(:) = rkappa*temp*(1.+q(:,1)*rv/rd)/(play*(1.+q(:,1)))
+
+
+      do k=2,llm-1
+
+       dph  (k-1) = (play(k  )- play(k-1  ))
+!       dudp (k-1) = (u   (k  )- u   (k-1  ))/dph(k-1)
+!       dvdp (k-1) = (v   (k  )- v   (k-1  ))/dph(k-1)
+       dqdp (k-1) = (q   (k,1)- q   (k-1,1))/dph(k-1)
+       dtdp (k-1) = (temp(k  )- temp(k-1  ))/dph(k-1)
+
+      enddo
+
+!      dudp (  llm  ) = dudp ( llm-1 )
+!      dvdp (  llm  ) = dvdp ( llm-1 )
+      dqdp (  llm  ) = dqdp ( llm-1 )
+      dtdp (  llm  ) = dtdp ( llm-1 )
+
+      do k=2,llm-1
+      omdn=max(0.0,omega(k+1))
+      omup=min(0.0,omega( k ))
+
+!      d_u_va(k)  = -omdn*dudp(k)-omup*dudp(k-1)
+!      d_v_va(k)  = -omdn*dvdp(k)-omup*dvdp(k-1)
+      d_q_va(k,1)= -omdn*dqdp(k)-omup*dqdp(k-1)
+      d_t_va(k)  = -omdn*dtdp(k)-omup*dtdp(k-1)+(omup+omdn)*cor(k)
+      enddo
+
+      omdn=max(0.0,omega( 2 ))
+      omup=min(0.0,omega(llm))
+!      d_u_va( 1 )   = -omdn*dudp( 1 )
+!      d_u_va(llm)   = -omup*dudp(llm)
+!      d_v_va( 1 )   = -omdn*dvdp( 1 )
+!      d_v_va(llm)   = -omup*dvdp(llm)
+      d_q_va( 1 ,1) = -omdn*dqdp( 1 )
+      d_q_va(llm,1) = -omup*dqdp(llm)
+      d_t_va( 1 )   = -omdn*dtdp( 1 )+omdn*cor( 1 )
+      d_t_va(llm)   = -omup*dtdp(llm)!+omup*cor(llm)
+
+!      if(abs(rlat(1))>10.) then
+!     Calculate the tendency due agestrophic motions
+!      du_age = fcoriolis*(v-vg)
+!      dv_age = fcoriolis*(ug-u)
+!      endif
+
+!       call writefield_phy('d_t_va',d_t_va,llm)
+
+          return
+         end
+
+!======================================================================
+      SUBROUTINE read_togacoare(fich_toga,nlev_toga,nt_toga                     &
+     &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga        &
+     &             ,ht_toga,vt_toga,hq_toga,vq_toga)
+      implicit none
+
+!-------------------------------------------------------------------------
+! Read TOGA-COARE forcing data 
+!-------------------------------------------------------------------------
+
+      integer nlev_toga,nt_toga
+      real ts_toga(nt_toga),plev_toga(nlev_toga,nt_toga)
+      real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)
+      real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)
+      real w_toga(nlev_toga,nt_toga)
+      real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
+      real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
+      character*80 fich_toga
+
+      integer k,ip
+      real bid
+
+      integer iy,im,id,ih
+      
+       real plev_min
+
+       plev_min = 55.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
+
+      open(21,file=trim(fich_toga),form='formatted')
+      read(21,'(a)') 
+      do ip = 1, nt_toga
+      read(21,'(a)') 
+      read(21,'(a)') 
+      read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid
+      read(21,'(a)') 
+      read(21,'(a)') 
+
+       do k = 1, nlev_toga
+         read(21,230) plev_toga(k,ip), t_toga(k,ip), q_toga(k,ip)          &
+     &       ,u_toga(k,ip), v_toga(k,ip), w_toga(k,ip)                     &
+     &       ,ht_toga(k,ip), vt_toga(k,ip), hq_toga(k,ip), vq_toga(k,ip)
+
+! conversion in SI units:
+         t_toga(k,ip)=t_toga(k,ip)+273.15     ! K
+         q_toga(k,ip)=q_toga(k,ip)*0.001      ! kg/kg
+         w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s
+! no water vapour tendency above 55 hPa
+         if (plev_toga(k,ip) .lt. plev_min) then
+          q_toga(k,ip) = 0.
+          hq_toga(k,ip) = 0.
+          vq_toga(k,ip) =0.
+         endif
+       enddo
+
+         ts_toga(ip)=ts_toga(ip)+273.15       ! K
+       enddo
+       close(21)
+
+  223 format(4i3,6f8.2)
+  230 format(6f9.3,4e11.3)
+
+          return
+          end
+
+!-------------------------------------------------------------------------
+      SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
+      implicit none
+
+!-------------------------------------------------------------------------
+! Read I.SANDU case forcing data
+!-------------------------------------------------------------------------
+
+      integer nlev_sandu,nt_sandu
+      real ts_sandu(nt_sandu)
+      character*80 fich_sandu
+
+      integer ip
+      integer iy,im,id,ih
+
+      real plev_min
+
+      print*,'nlev_sandu',nlev_sandu
+      plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
+
+      open(21,file=trim(fich_sandu),form='formatted')
+      read(21,'(a)')
+      do ip = 1, nt_sandu
+      read(21,'(a)')
+      read(21,'(a)')
+      read(21,223) iy, im, id, ih, ts_sandu(ip)
+      print *,'ts=',iy,im,id,ih,ip,ts_sandu(ip)
+      enddo
+      close(21)
+
+  223 format(4i3,f8.2)
+
+          return
+          end
+
+!=====================================================================
+!-------------------------------------------------------------------------
+      SUBROUTINE read_astex(fich_astex,nlev_astex,nt_astex,div_astex,      &
+     & ts_astex,ug_astex,vg_astex,ufa_astex,vfa_astex)
+      implicit none
+
+!-------------------------------------------------------------------------
+! Read Astex case forcing data
+!-------------------------------------------------------------------------
+
+      integer nlev_astex,nt_astex
+      real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
+      real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
+      character*80 fich_astex
+
+      integer ip
+      integer iy,im,id,ih
+
+       real plev_min
+
+      print*,'nlev_astex',nlev_astex
+       plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
+
+      open(21,file=trim(fich_astex),form='formatted')
+      read(21,'(a)')
+      read(21,'(a)')
+      do ip = 1, nt_astex
+      read(21,'(a)')
+      read(21,'(a)')
+      read(21,223) iy, im, id, ih, div_astex(ip),ts_astex(ip),             &
+     &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vfa_astex(ip)
+      ts_astex(ip)=ts_astex(ip)+273.15
+      print *,'ts=',iy,im,id,ih,ip,div_astex(ip),ts_astex(ip),             &
+     &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vg_astex(ip)
+      enddo
+      close(21)
+
+  223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)
+
+          return
+          end
+!=====================================================================
+      subroutine read_twpice(fich_twpice,nlevel,ntime                       &
+     &     ,T_srf,plev,T,q,u,v,omega                                       &
+     &     ,T_adv_h,T_adv_v,q_adv_h,q_adv_v)
+
+!program reading forcings of the TWP-ICE experiment
+
+!      use netcdf
+
+      implicit none
+
+#include "netcdf.inc"
+
+      integer ntime,nlevel
+      integer l,k
+      character*80 :: fich_twpice
+      real*8 time(ntime)
+      real*8 lat, lon, alt, phis
+      real*8 lev(nlevel)
+      real*8 plev(nlevel,ntime)
+
+      real*8 T(nlevel,ntime)
+      real*8 q(nlevel,ntime),u(nlevel,ntime)
+      real*8 v(nlevel,ntime)
+      real*8 omega(nlevel,ntime), div(nlevel,ntime)
+      real*8 T_adv_h(nlevel,ntime)
+      real*8 T_adv_v(nlevel,ntime), q_adv_h(nlevel,ntime)
+      real*8 q_adv_v(nlevel,ntime)
+      real*8 s(nlevel,ntime), s_adv_h(nlevel,ntime)
+      real*8 s_adv_v(nlevel,ntime)
+      real*8 p_srf_aver(ntime), p_srf_center(ntime)
+      real*8 T_srf(ntime)
+
+      integer nid, ierr
+      integer nbvar3d
+      parameter(nbvar3d=20)
+      integer var3didin(nbvar3d)
+
+      ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: Pb opening forcings cdf file '
+         write(*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+      ierr=NF_INQ_VARID(nid,"lat",var3didin(1))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lat'
+         endif
+      
+       ierr=NF_INQ_VARID(nid,"lon",var3didin(2))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lon'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"alt",var3didin(3))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'alt'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"phis",var3didin(4))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'phis'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"T",var3didin(5))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'T'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"q",var3didin(6))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'q'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"u",var3didin(7))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'u'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"v",var3didin(8))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"omega",var3didin(9))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'omega'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"div",var3didin(10))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'div'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'T_adv_h'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'T_adv_v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'q_adv_h'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'q_adv_v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"s",var3didin(15))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 's'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 's_adv_h'
+         endif
+    
+      ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 's_adv_v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'p_srf_aver'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'p_srf_center'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'T_srf'
+         endif
+
+!dimensions lecture
+      call catchaxis(nid,ntime,nlevel,time,lev,ierr)
+
+!pressure 
+       do l=1,ntime
+       do k=1,nlevel
+          plev(k,l)=lev(k)
+       enddo
+       enddo
+          
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture lat ok',lat
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture lon ok',lon
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture alt ok',alt
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture phis ok',phis
+          
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture T ok'
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture q ok'
+!q in kg/kg
+       do l=1,ntime
+       do k=1,nlevel
+          q(k,l)=q(k,l)/1000.
+       enddo
+       enddo
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture u ok'
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture v ok'
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture omega ok'
+!omega in mb/hour
+       do l=1,ntime
+       do k=1,nlevel
+          omega(k,l)=omega(k,l)*100./3600.
+       enddo
+       enddo
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture div ok'
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture T_adv_h ok'
+!T adv in K/s
+       do l=1,ntime
+       do k=1,nlevel
+          T_adv_h(k,l)=T_adv_h(k,l)/3600.
+       enddo
+       enddo
+
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture T_adv_v ok'
+!T adv in K/s
+       do l=1,ntime
+       do k=1,nlevel
+          T_adv_v(k,l)=T_adv_v(k,l)/3600.
+       enddo
+       enddo
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture q_adv_h ok'
+!q adv in kg/kg/s
+       do l=1,ntime
+       do k=1,nlevel
+          q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.
+       enddo
+       enddo
+
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture q_adv_v ok'
+!q adv in kg/kg/s
+       do l=1,ntime
+       do k=1,nlevel
+          q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.
+       enddo
+       enddo
+
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture T_srf ok', T_srf
+
+         return 
+         end subroutine read_twpice
+!=====================================================================
+         subroutine catchaxis(nid,ttm,llm,time,lev,ierr)
+
+!         use netcdf
+
+         implicit none
+#include "netcdf.inc"
+         integer nid,ttm,llm
+         real*8 time(ttm)
+         real*8 lev(llm)
+         integer ierr
+
+         integer timevar,levvar
+         integer timelen,levlen
+         integer timedimin,levdimin
+
+! Control & lecture on dimensions
+! ===============================
+         ierr=NF_INQ_DIMID(nid,"time",timedimin)
+         ierr=NF_INQ_VARID(nid,"time",timevar)
+         if (ierr.NE.NF_NOERR) then
+            write(*,*) 'ERROR: Field <time> is missing'
+            stop ""  
+         endif
+         ierr=NF_INQ_DIMLEN(nid,timedimin,timelen)
+
+         ierr=NF_INQ_DIMID(nid,"lev",levdimin)
+         ierr=NF_INQ_VARID(nid,"lev",levvar)
+         if (ierr.NE.NF_NOERR) then
+             write(*,*) 'ERROR: Field <lev> is lacking'
+             stop "" 
+         endif
+         ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)
+
+         if((timelen/=ttm).or.(levlen/=llm)) then
+            write(*,*) 'ERROR: Not the good lenght for axis'
+            write(*,*) 'longitude: ',timelen,ttm+1
+            write(*,*) 'latitude: ',levlen,llm
+            stop ""  
+         endif
+
+!#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)
+         ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)
+!#else
+!        ierr = NF_GET_VAR_REAL(nid,timevar,time)
+!        ierr = NF_GET_VAR_REAL(nid,levvar,lev)
+!#endif
+
+       return
+       end
+!=====================================================================
+
+       SUBROUTINE interp_sandu_vertical(play,nlev_sandu,plev_prof          &
+     &         ,t_prof,thl_prof,q_prof,u_prof,v_prof,w_prof                &
+     &         ,omega_prof,o3mmr_prof                                      &
+     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                      &
+     &         ,omega_mod,o3mmr_mod,mxcalc)
+
+       implicit none
+
+#include "dimensions.h"
+
+!-------------------------------------------------------------------------
+! Vertical interpolation of SANDUREF forcing data onto model levels
+!-------------------------------------------------------------------------
+
+       integer nlevmax
+       parameter (nlevmax=41)
+       integer nlev_sandu,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_prof(nlev_sandu)
+       real t_prof(nlev_sandu),thl_prof(nlev_sandu),q_prof(nlev_sandu)
+       real u_prof(nlev_sandu),v_prof(nlev_sandu), w_prof(nlev_sandu)
+       real omega_prof(nlev_sandu),o3mmr_prof(nlev_sandu)
+
+       real t_mod(llm),thl_mod(llm),q_mod(llm)
+       real u_mod(llm),v_mod(llm), w_mod(llm)
+       real omega_mod(llm),o3mmr_mod(llm)
+
+       integer l,k,k1,k2
+       real frac,frac1,frac2,fact
+
+       do l = 1, llm
+
+        if (play(l).ge.plev_prof(nlev_sandu)) then
+
+        mxcalc=l
+         k1=0
+         k2=0
+
+         if (play(l).le.plev_prof(1)) then
+
+         do k = 1, nlev_sandu-1
+          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_sandu-1
+          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
+         enddo
+         endif
+
+         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
+         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
+         thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
+         q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
+         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
+         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
+         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
+         omega_mod(l)=omega_prof(k2)-frac*(omega_prof(k2)-omega_prof(k1))
+         o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
+
+         else !play>plev_prof(1)
+
+         k1=1
+         k2=2
+         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
+         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
+         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
+         thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
+         q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
+         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
+         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
+         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
+         omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
+         o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
+
+         endif ! play.le.plev_prof(1)
+
+        else ! above max altitude of forcing file
+
+!jyg
+         fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg
+         fact = max(fact,0.)                                           !jyg
+         fact = exp(-fact)                                             !jyg
+         t_mod(l)= t_prof(nlev_sandu)                                   !jyg
+         thl_mod(l)= thl_prof(nlev_sandu)                                   !jyg
+         q_mod(l)= q_prof(nlev_sandu)*fact                              !jyg
+         u_mod(l)= u_prof(nlev_sandu)*fact                              !jyg
+         v_mod(l)= v_prof(nlev_sandu)*fact                              !jyg
+         w_mod(l)= w_prof(nlev_sandu)*fact                              !jyg
+         omega_mod(l)= omega_prof(nlev_sandu)*fact                      !jyg
+         o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact                      !jyg
+
+        endif ! play
+
+       enddo ! l
+
+       do l = 1,llm
+!      print *,'t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l) ',
+!    $        l,t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l)
+       enddo
+
+          return
+          end
+!=====================================================================
+       SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof          &
+     &         ,t_prof,thl_prof,qv_prof,ql_prof,qt_prof,u_prof,v_prof      &
+     &         ,w_prof,tke_prof,o3mmr_prof                                 &
+     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod       &
+     &         ,tke_mod,o3mmr_mod,mxcalc)
+
+       implicit none
+
+#include "dimensions.h"
+
+!-------------------------------------------------------------------------
+! Vertical interpolation of Astex forcing data onto model levels
+!-------------------------------------------------------------------------
+
+       integer nlevmax
+       parameter (nlevmax=41)
+       integer nlev_astex,mxcalc
+!       real play(llm), plev_prof(nlevmax)
+!       real t_prof(nlevmax),qv_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_prof(nlev_astex)
+       real t_prof(nlev_astex),thl_prof(nlev_astex),qv_prof(nlev_astex)
+       real u_prof(nlev_astex),v_prof(nlev_astex), w_prof(nlev_astex)
+       real o3mmr_prof(nlev_astex),ql_prof(nlev_astex)
+       real qt_prof(nlev_astex),tke_prof(nlev_astex)
+
+       real t_mod(llm),thl_mod(llm),qv_mod(llm)
+       real u_mod(llm),v_mod(llm), w_mod(llm),tke_mod(llm)
+       real o3mmr_mod(llm),ql_mod(llm),qt_mod(llm)
+
+       integer l,k,k1,k2
+       real frac,frac1,frac2,fact
+
+       do l = 1, llm
+
+        if (play(l).ge.plev_prof(nlev_astex)) then
+
+        mxcalc=l
+         k1=0
+         k2=0
+
+         if (play(l).le.plev_prof(1)) then
+
+         do k = 1, nlev_astex-1
+          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_astex-1
+          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
+         enddo
+         endif
+
+         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
+         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
+         thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
+         qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
+         ql_mod(l)= ql_prof(k2) - frac*(ql_prof(k2)-ql_prof(k1))
+         qt_mod(l)= qt_prof(k2) - frac*(qt_prof(k2)-qt_prof(k1))
+         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
+         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
+         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
+         tke_mod(l)= tke_prof(k2) - frac*(tke_prof(k2)-tke_prof(k1))
+         o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
+
+         else !play>plev_prof(1)
+
+         k1=1
+         k2=2
+         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
+         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
+         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
+         thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
+         qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
+         ql_mod(l)= frac1*ql_prof(k1) - frac2*ql_prof(k2)
+         qt_mod(l)= frac1*qt_prof(k1) - frac2*qt_prof(k2)
+         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
+         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
+         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
+         tke_mod(l)= frac1*tke_prof(k1) - frac2*tke_prof(k2)
+         o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
+
+         endif ! play.le.plev_prof(1)
+
+        else ! above max altitude of forcing file
+
+!jyg
+         fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg
+         fact = max(fact,0.)                                           !jyg
+         fact = exp(-fact)                                             !jyg
+         t_mod(l)= t_prof(nlev_astex)                                   !jyg
+         thl_mod(l)= thl_prof(nlev_astex)                                   !jyg
+         qv_mod(l)= qv_prof(nlev_astex)*fact                              !jyg
+         ql_mod(l)= ql_prof(nlev_astex)*fact                              !jyg
+         qt_mod(l)= qt_prof(nlev_astex)*fact                              !jyg
+         u_mod(l)= u_prof(nlev_astex)*fact                              !jyg
+         v_mod(l)= v_prof(nlev_astex)*fact                              !jyg
+         w_mod(l)= w_prof(nlev_astex)*fact                              !jyg
+         tke_mod(l)= tke_prof(nlev_astex)*fact                              !jyg
+         o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact                      !jyg
+
+        endif ! play
+
+       enddo ! l
+
+       do l = 1,llm
+!      print *,'t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l) ',
+!    $        l,t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l)
+       enddo
+
+          return
+          end
+
+!======================================================================
+      SUBROUTINE read_rico(fich_rico,nlev_rico,ps_rico,play                &
+     &             ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico             &
+     &             ,dth_dyn,dqh_dyn)
+      implicit none
+
+!-------------------------------------------------------------------------
+! Read RICO forcing data 
+!-------------------------------------------------------------------------
+#include "dimensions.h"
+
+
+      integer nlev_rico
+      real ts_rico,ps_rico
+      real t_rico(llm),q_rico(llm)
+      real u_rico(llm),v_rico(llm)
+      real w_rico(llm)
+      real dth_dyn(llm)
+      real dqh_dyn(llm)
+      
+
+      real play(llm),zlay(llm)
+     
+
+      real prico(nlev_rico),zrico(nlev_rico)
+
+      character*80 fich_rico
+
+      integer k,l
+
+      
+      print*,fich_rico
+      open(21,file=trim(fich_rico),form='formatted')
+        do k=1,llm
+      zlay(k)=0.
+         enddo
+      
+        read(21,*) ps_rico,ts_rico
+        prico(1)=ps_rico
+        zrico(1)=0.0
+      do l=2,nlev_rico
+        read(21,*) k,prico(l),zrico(l)
+      enddo
+       close(21)
+
+      do k=1,llm
+        do l=1,80
+          if(prico(l)>play(k)) then
+              if(play(k)>prico(l+1)) then
+                zlay(k)=zrico(l)+(play(k)-prico(l)) *                      &
+     &              (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))
+              else 
+                zlay(k)=zrico(l)+(play(k)-prico(80))*                      &
+     &              (zrico(81)-zrico(80))/(prico(81)-prico(80))
+              endif
+          endif
+        enddo
+        print*,k,zlay(k)
+        ! U
+        if(0 < zlay(k) .and. zlay(k) < 4000) then
+          u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/4000
+        elseif(4000 < zlay(k) .and. zlay(k) < 12000) then
+       u_rico(k)=  -1.9 + (30.0 + 1.9) /                                   &
+     &          (12000 - 4000) * (zlay(k) - 4000)
+        elseif(12000 < zlay(k) .and. zlay(k) < 13000) then
+          u_rico(k)=30.0
+        elseif(13000 < zlay(k) .and. zlay(k) < 20000) then
+          u_rico(k)=30.0 - (30.0) /                                        &
+     & (20000 - 13000) * (zlay(k) - 13000)
+        else
+          u_rico(k)=0.0
+        endif
+
+!Q_v
+        if(0 < zlay(k) .and. zlay(k) < 740) then
+          q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)
+        elseif(740 < zlay(k) .and. zlay(k) < 3260) then
+          q_rico(k)=13.8 + (2.4 - 13.8) /                                   &
+     &          (3260 - 740) * (zlay(k) - 740)
+        elseif(3260 < zlay(k) .and. zlay(k) < 4000) then
+          q_rico(k)=2.4 + (1.8 - 2.4) /                                    &
+     &               (4000 - 3260) * (zlay(k) - 3260)
+        elseif(4000 < zlay(k) .and. zlay(k) < 9000) then
+          q_rico(k)=1.8 + (0 - 1.8) /                                      &
+     &             (9000 - 4000) * (zlay(k) - 4000)
+        else
+          q_rico(k)=0.0
+        endif
+
+!T
+        if(0 < zlay(k) .and. zlay(k) < 740) then
+          t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)
+        elseif(740 < zlay(k) .and. zlay(k) < 4000) then
+          t_rico(k)=292.0 + (278.0 - 292.0) /                              &                       
+     &       (4000 - 740) * (zlay(k) - 740)
+        elseif(4000 < zlay(k) .and. zlay(k) < 15000) then
+          t_rico(k)=278.0 + (203.0 - 278.0) /                              &
+     &       (15000 - 4000) * (zlay(k) - 4000)
+        elseif(15000 < zlay(k) .and. zlay(k) < 17500) then
+          t_rico(k)=203.0 + (194.0 - 203.0) /                              & 
+     &       (17500 - 15000)* (zlay(k) - 15000)
+        elseif(17500 < zlay(k) .and. zlay(k) < 20000) then
+          t_rico(k)=194.0 + (206.0 - 194.0) /                              &
+     &       (20000 - 17500)* (zlay(k) - 17500)
+        elseif(20000 < zlay(k) .and. zlay(k) < 60000) then
+          t_rico(k)=206.0 + (270.0 - 206.0) /                              & 
+     &        (60000 - 20000)* (zlay(k) - 20000)
+        endif
+
+! W
+        if(0 < zlay(k) .and. zlay(k) < 2260 ) then
+          w_rico(k)=- (0.005/2260) * zlay(k)
+        elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then
+          w_rico(k)=- 0.005
+        elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then
+       w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)
+        else
+          w_rico(k)=0.0
+        endif
+
+! dThrz+dTsw0+dTlw0
+        if(0 < zlay(k) .and. zlay(k) < 4000) then
+          dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/                     &
+     &               (86400*4000) * zlay(k)
+        elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
+          dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) /                           &
+     &           (86400*(5000 - 4000)) * (zlay(k) - 4000)
+        else
+          dth_dyn(k)=0.0
+        endif
+! dQhrz
+        if(0 < zlay(k) .and. zlay(k) < 3000) then
+          dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/                         &
+     &                    (86400*3000) * (zlay(k))
+        elseif(3000 < zlay(k) .and. zlay(k) < 4000) then
+          dqh_dyn(k)=0.345 / 86400
+        elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
+          dqh_dyn(k)=0.345 / 86400 +                                       &
+     &   (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)
+        else
+          dqh_dyn(k)=0.0
+        endif
+
+!?        if(play(k)>6e4) then
+!?          ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)
+!?        elseif((play(k)>3e4).and.(play(k)<6e4)) then
+!?          ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&
+!?                          *(6e4-play(k))/(6e4-3e4)
+!?        else
+!?          ratqs0(1,k)=ratqshaut
+!?        endif
+
+      enddo
+
+      do k=1,llm
+      q_rico(k)=q_rico(k)/1e3 
+      dqh_dyn(k)=dqh_dyn(k)/1e3
+      v_rico(k)=-3.8
+      enddo
+
+          return
+          end
+
+!======================================================================
+        SUBROUTINE interp_sandu_time(day,day1,annee_ref                    &
+     &             ,year_ini_sandu,day_ini_sandu,nt_sandu,dt_sandu         &
+     &             ,nlev_sandu,ts_sandu,ts_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_sandu: total nb of data in the forcing (e.g. 13 for Sanduref)
+! dt_sandu: total time interval (in sec) between 2 forcing data (e.g. 6h for Sanduref)
+!---------------------------------------------------------------------------------------
+! inputs:
+        integer annee_ref
+        integer nt_sandu,nlev_sandu
+        integer year_ini_sandu
+        real day, day1,day_ini_sandu,dt_sandu
+        real ts_sandu(nt_sandu)
+! outputs:
+        real ts_prof
+! local:
+        integer it_sandu1, it_sandu2
+        real timeit,time_sandu1,time_sandu2,frac
+! Check that initial day of the simulation consistent with SANDU period:
+       if (annee_ref.ne.2006 ) then
+        print*,'Pour SANDUREF, annee_ref doit etre 2006 '
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+!      if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then
+!       print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'
+!       print*,'Changer dayref dans run.def'
+!       stop
+!      endif
+
+! Determine timestep relative to the 1st day of TOGA-COARE:
+!       timeit=(day-day1)*86400.
+!       if (annee_ref.eq.1992) then
+!        timeit=(day-day_ini_sandu)*86400.
+!       else
+!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+!       endif
+      timeit=(day-day_ini_sandu)*86400
+
+! Determine the closest observation times:
+       it_sandu1=INT(timeit/dt_sandu)+1
+       it_sandu2=it_sandu1 + 1
+       time_sandu1=(it_sandu1-1)*dt_sandu
+       time_sandu2=(it_sandu2-1)*dt_sandu
+       print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu
+       print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2',              &
+     &          it_sandu1,it_sandu2,time_sandu1,time_sandu2
+
+       if (it_sandu1 .ge. nt_sandu) then
+        write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: '          &
+     &        ,day,it_sandu1,it_sandu2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       frac=(time_sandu2-timeit)/(time_sandu2-time_sandu1)
+       frac=max(frac,0.0)
+
+       ts_prof = ts_sandu(it_sandu2)                                       &
+     &          -frac*(ts_sandu(it_sandu2)-ts_sandu(it_sandu1))
+
+         print*,                                                           &
+     &'day,annee_ref,day_ini_sandu,timeit,it_sandu1,it_sandu2,SST:',       &
+     &day,annee_ref,day_ini_sandu,timeit/86400.,it_sandu1,                  &
+     &it_sandu2,ts_prof
+
+        return
+        END
+!=====================================================================
+!-------------------------------------------------------------------------
+      SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu,                &
+     & sens,flat,adv_theta,rad_theta,adv_qt)
+      implicit none
+
+!-------------------------------------------------------------------------
+! Read ARM_CU case forcing data
+!-------------------------------------------------------------------------
+
+      integer nlev_armcu,nt_armcu
+      real sens(nt_armcu),flat(nt_armcu)
+      real adv_theta(nt_armcu),rad_theta(nt_armcu),adv_qt(nt_armcu)
+      character*80 fich_armcu
+
+      integer ip
+
+      integer iy,im,id,ih,in
+
+      print*,'nlev_armcu',nlev_armcu
+
+      open(21,file=trim(fich_armcu),form='formatted')
+      read(21,'(a)')
+      do ip = 1, nt_armcu
+      read(21,'(a)')
+      read(21,'(a)')
+      read(21,223) iy, im, id, ih, in, sens(ip),flat(ip),                  &
+     &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
+      print *,'forcages=',iy,im,id,ih,in, sens(ip),flat(ip),               &
+     &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
+      enddo
+      close(21)
+
+  223 format(5i3,5f8.3)
+
+          return
+          end
+
+!=====================================================================
+       SUBROUTINE interp_toga_vertical(play,nlev_toga,plev_prof            &
+     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                         &
+     &         ,ht_prof,vt_prof,hq_prof,vq_prof                            &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                              &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+ 
+       implicit none
+ 
+#include "dimensions.h"
+
+!-------------------------------------------------------------------------
+! Vertical interpolation of TOGA-COARE forcing data onto model levels
+!-------------------------------------------------------------------------
+ 
+       integer nlevmax
+       parameter (nlevmax=41)
+       integer nlev_toga,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_prof(nlev_toga) 
+       real t_prof(nlev_toga),q_prof(nlev_toga)
+       real u_prof(nlev_toga),v_prof(nlev_toga), w_prof(nlev_toga)
+       real ht_prof(nlev_toga),vt_prof(nlev_toga)
+       real hq_prof(nlev_toga),vq_prof(nlev_toga)
+ 
+       real t_mod(llm),q_mod(llm)
+       real u_mod(llm),v_mod(llm), w_mod(llm)
+       real ht_mod(llm),vt_mod(llm)
+       real hq_mod(llm),vq_mod(llm)
+ 
+       integer l,k,k1,k2
+       real frac,frac1,frac2,fact
+ 
+       do l = 1, llm
+
+        if (play(l).ge.plev_prof(nlev_toga)) then
+ 
+        mxcalc=l
+         k1=0
+         k2=0
+
+         if (play(l).le.plev_prof(1)) then
+
+         do k = 1, nlev_toga-1
+          if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(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_toga-1
+          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
+         enddo
+         endif
+
+         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
+         t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
+         q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
+         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
+         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
+         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
+         ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
+         vt_mod(l)= vt_prof(k2) - frac*(vt_prof(k2)-vt_prof(k1))
+         hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
+         vq_mod(l)= vq_prof(k2) - frac*(vq_prof(k2)-vq_prof(k1))
+     
+         else !play>plev_prof(1)
+
+         k1=1
+         k2=2
+         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
+         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
+         t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
+         q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
+         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
+         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
+         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
+         ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
+         vt_mod(l)= frac1*vt_prof(k1) - frac2*vt_prof(k2)
+         hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
+         vq_mod(l)= frac1*vq_prof(k1) - frac2*vq_prof(k2)
+
+         endif ! play.le.plev_prof(1)
+
+        else ! above max altitude of forcing file
+ 
+!jyg
+         fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg
+         fact = max(fact,0.)                                           !jyg
+         fact = exp(-fact)                                             !jyg
+         t_mod(l)= t_prof(nlev_toga)                                   !jyg
+         q_mod(l)= q_prof(nlev_toga)*fact                              !jyg
+         u_mod(l)= u_prof(nlev_toga)*fact                              !jyg
+         v_mod(l)= v_prof(nlev_toga)*fact                              !jyg
+         w_mod(l)= 0.0                                                 !jyg
+         ht_mod(l)= ht_prof(nlev_toga)                                 !jyg
+         vt_mod(l)= vt_prof(nlev_toga)                                 !jyg
+         hq_mod(l)= hq_prof(nlev_toga)*fact                            !jyg
+         vq_mod(l)= vq_prof(nlev_toga)*fact                            !jyg
+ 
+        endif ! play
+ 
+       enddo ! l
+
+!       do l = 1,llm
+!       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
+!     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
+!       enddo
+ 
+          return
+          end
+ 
+!=====================================================================
+       SUBROUTINE interp_case_vertical(play,nlev_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                            &
+     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
+ 
+       implicit none
+ 
+#include "dimensions.h"
+
+!-------------------------------------------------------------------------
+! Vertical interpolation of TOGA-COARE 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_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), 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),dtrad_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),q_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)
+       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 dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)
+ 
+       integer l,k,k1,k2
+       real frac,frac1,frac2,fact
+ 
+       do l = 1, llm
+
+        if (play(l).ge.plev_prof_cas(nlev_cas)) then
+ 
+        mxcalc=l
+         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))
+         q_mod_cas(l)= q_prof_cas(k2) - frac*(q_prof_cas(k2)-q_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))
+         w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_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))
+         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))
+     
+         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))
+         t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)
+         q_mod_cas(l)= frac1*q_prof_cas(k1) - frac2*q_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)
+         w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_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)
+         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)
+
+         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
+         q_mod_cas(l)= q_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)*fact                              !jyg
+         vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact                              !jyg
+         w_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
+         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
+ 
+        endif ! play
+ 
+       enddo ! l
+
+!       do l = 1,llm
+!       print *,'t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l) ',
+!     $        l,t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l)
+!       enddo
+ 
+          return
+          end
+!***************************************************************************** 
+!=====================================================================
+       SUBROUTINE interp_dice_vertical(play,nlev_dice,nt_dice,plev_prof   &
+     &         ,th_prof,qv_prof,u_prof,v_prof,o3_prof                     &
+     &         ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof         &
+     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                          &
+     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
+ 
+       implicit none
+ 
+#include "dimensions.h"
+
+!-------------------------------------------------------------------------
+! Vertical interpolation of Dice forcing data onto model levels
+!-------------------------------------------------------------------------
+ 
+       integer nlevmax
+       parameter (nlevmax=41)
+       integer nlev_dice,mxcalc,nt_dice
+ 
+       real play(llm), plev_prof(nlev_dice) 
+       real th_prof(nlev_dice),qv_prof(nlev_dice)
+       real u_prof(nlev_dice),v_prof(nlev_dice) 
+       real o3_prof(nlev_dice)
+       real ht_prof(nlev_dice),hq_prof(nlev_dice)
+       real hu_prof(nlev_dice),hv_prof(nlev_dice)
+       real w_prof(nlev_dice),omega_prof(nlev_dice)
+ 
+       real th_mod(llm),qv_mod(llm)
+       real u_mod(llm),v_mod(llm), o3_mod(llm)
+       real ht_mod(llm),hq_mod(llm)
+       real hu_mod(llm),hv_mod(llm),w_mod(llm),omega_mod(llm)
+ 
+       integer l,k,k1,k2,kp
+       real aa,frac,frac1,frac2,fact
+ 
+       do l = 1, llm
+
+        if (play(l).ge.plev_prof(nlev_dice)) then
+ 
+        mxcalc=l
+         k1=0
+         k2=0
+
+         if (play(l).le.plev_prof(1)) then
+
+         do k = 1, nlev_dice-1
+          if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(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_dice-1
+          write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
+         enddo
+         endif
+
+         frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
+         th_mod(l)= th_prof(k2) - frac*(th_prof(k2)-th_prof(k1))
+         qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
+         u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
+         v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
+         o3_mod(l)= o3_prof(k2) - frac*(o3_prof(k2)-o3_prof(k1))
+         ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
+         hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
+         hu_mod(l)= hu_prof(k2) - frac*(hu_prof(k2)-hu_prof(k1))
+         hv_mod(l)= hv_prof(k2) - frac*(hv_prof(k2)-hv_prof(k1))
+         w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
+         omega_mod(l)= omega_prof(k2) - frac*(omega_prof(k2)-omega_prof(k1))
+     
+         else !play>plev_prof(1)
+
+         k1=1
+         k2=2
+         frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
+         frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
+         th_mod(l)= frac1*th_prof(k1) - frac2*th_prof(k2)
+         qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
+         u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
+         v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
+         o3_mod(l)= frac1*o3_prof(k1) - frac2*o3_prof(k2)
+         ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
+         hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
+         hu_mod(l)= frac1*hu_prof(k1) - frac2*hu_prof(k2)
+         hv_mod(l)= frac1*hv_prof(k1) - frac2*hv_prof(k2)
+         w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
+         omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
+
+         endif ! play.le.plev_prof(1)
+
+        else ! above max altitude of forcing file
+ 
+!jyg
+         fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg
+         fact = max(fact,0.)                                           !jyg
+         fact = exp(-fact)                                             !jyg
+         th_mod(l)= th_prof(nlev_dice)                                 !jyg
+         qv_mod(l)= qv_prof(nlev_dice)*fact                            !jyg
+         u_mod(l)= u_prof(nlev_dice)*fact                              !jyg
+         v_mod(l)= v_prof(nlev_dice)*fact                              !jyg
+         o3_mod(l)= o3_prof(nlev_dice)*fact                            !jyg
+         ht_mod(l)= ht_prof(nlev_dice)                                 !jyg
+         hq_mod(l)= hq_prof(nlev_dice)*fact                            !jyg
+         hu_mod(l)= hu_prof(nlev_dice)                                 !jyg
+         hv_mod(l)= hv_prof(nlev_dice)                                 !jyg
+         w_mod(l)= 0.                                                  !jyg
+         omega_mod(l)= 0.                                              !jyg
+ 
+        endif ! play
+ 
+       enddo ! l
+
+!       do l = 1,llm
+!       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
+!     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
+!       enddo
+ 
+          return
+          end
+
+!======================================================================
+        SUBROUTINE interp_astex_time(day,day1,annee_ref                    &
+     &             ,year_ini_astex,day_ini_astex,nt_astex,dt_astex         &
+     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex        &
+     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof   &
+     &             ,ufa_prof,vfa_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_astex: total nb of data in the forcing (e.g. 41 for Astex)
+! dt_astex: total time interval (in sec) between 2 forcing data (e.g. 1h for Astex)
+!---------------------------------------------------------------------------------------
+
+! inputs:
+        integer annee_ref
+        integer nt_astex,nlev_astex
+        integer year_ini_astex
+        real day, day1,day_ini_astex,dt_astex
+        real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
+        real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
+! outputs:
+        real div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
+! local:
+        integer it_astex1, it_astex2
+        real timeit,time_astex1,time_astex2,frac
+
+! Check that initial day of the simulation consistent with ASTEX period:
+       if (annee_ref.ne.1992 ) then
+        print*,'Pour Astex, annee_ref doit etre 1992 '
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then
+        print*,'Astex debute le 13 Juin 1992 (jour julien=165)'
+        print*,'Changer dayref dans run.def'
+        stop
+       endif
+
+! Determine timestep relative to the 1st day of TOGA-COARE:
+!       timeit=(day-day1)*86400.
+!       if (annee_ref.eq.1992) then
+!        timeit=(day-day_ini_astex)*86400.
+!       else
+!        timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 1992
+!       endif
+      timeit=(day-day_ini_astex)*86400
+
+! Determine the closest observation times:
+       it_astex1=INT(timeit/dt_astex)+1
+       it_astex2=it_astex1 + 1
+       time_astex1=(it_astex1-1)*dt_astex
+       time_astex2=(it_astex2-1)*dt_astex
+       print *,'timeit day day_ini_astex',timeit,day,day_ini_astex
+       print *,'it_astex1,it_astex2,time_astex1,time_astex2',              &
+     &          it_astex1,it_astex2,time_astex1,time_astex2
+
+       if (it_astex1 .ge. nt_astex) then
+        write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: '          &
+     &        ,day,it_astex1,it_astex2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       frac=(time_astex2-timeit)/(time_astex2-time_astex1)
+       frac=max(frac,0.0)
+
+       div_prof = div_astex(it_astex2)                                     &
+     &          -frac*(div_astex(it_astex2)-div_astex(it_astex1))
+       ts_prof = ts_astex(it_astex2)                                        &
+     &          -frac*(ts_astex(it_astex2)-ts_astex(it_astex1))
+       ug_prof = ug_astex(it_astex2)                                       &
+     &          -frac*(ug_astex(it_astex2)-ug_astex(it_astex1))
+       vg_prof = vg_astex(it_astex2)                                       &
+     &          -frac*(vg_astex(it_astex2)-vg_astex(it_astex1))
+       ufa_prof = ufa_astex(it_astex2)                                     &
+     &          -frac*(ufa_astex(it_astex2)-ufa_astex(it_astex1))
+       vfa_prof = vfa_astex(it_astex2)                                     &
+     &          -frac*(vfa_astex(it_astex2)-vfa_astex(it_astex1))
+
+         print*,                                                           &
+     &'day,annee_ref,day_ini_astex,timeit,it_astex1,it_astex2,SST:',       &
+     &day,annee_ref,day_ini_astex,timeit/86400.,it_astex1,                 &
+     &it_astex2,div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof 
+
+        return
+        END
+
+!======================================================================
+        SUBROUTINE interp_toga_time(day,day1,annee_ref                     &
+     &             ,year_ini_toga,day_ini_toga,nt_toga,dt_toga,nlev_toga   &
+     &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga   &
+     &             ,ht_toga,vt_toga,hq_toga,vq_toga                        &
+     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof   &
+     &             ,ht_prof,vt_prof,hq_prof,vq_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_toga: total nb of data in the forcing (e.g. 480 for TOGA-COARE)
+! dt_toga: total time interval (in sec) between 2 forcing data (e.g. 6h for TOGA-COARE)
+!---------------------------------------------------------------------------------------
+
+#include "compar1d.h"
+
+! inputs:
+        integer annee_ref
+        integer nt_toga,nlev_toga
+        integer year_ini_toga
+        real day, day1,day_ini_toga,dt_toga
+        real ts_toga(nt_toga)
+        real plev_toga(nlev_toga,nt_toga),t_toga(nlev_toga,nt_toga)
+        real q_toga(nlev_toga,nt_toga),u_toga(nlev_toga,nt_toga)
+        real v_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)
+        real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
+        real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
+! outputs:
+        real ts_prof
+        real plev_prof(nlev_toga),t_prof(nlev_toga)
+        real q_prof(nlev_toga),u_prof(nlev_toga)
+        real v_prof(nlev_toga),w_prof(nlev_toga)
+        real ht_prof(nlev_toga),vt_prof(nlev_toga)
+        real hq_prof(nlev_toga),vq_prof(nlev_toga)
+! local:
+        integer it_toga1, it_toga2,k
+        real timeit,time_toga1,time_toga2,frac
+
+
+        if (forcing_type.eq.2) then
+! Check that initial day of the simulation consistent with TOGA-COARE period:
+       if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then
+        print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then
+        print*,'TOGA-COARE a débuté le 1er Nov 1992 (jour julien=306)'
+        print*,'Changer dayref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then
+        print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'
+        print*,'Changer dayref ou nday dans run.def'
+        stop
+       endif
+
+       else if (forcing_type.eq.4) then
+
+! Check that initial day of the simulation consistent with TWP-ICE period:
+       if (annee_ref.ne.2006) then
+        print*,'Pour TWP-ICE, annee_ref doit etre 2006'
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then
+        print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'
+        print*,'Changer dayref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then
+        print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'
+        print*,'Changer dayref ou nday dans run.def'
+        stop
+       endif
+
+       endif
+
+! Determine timestep relative to the 1st day of TOGA-COARE:
+!       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_toga)*86400
+
+! Determine the closest observation times:
+       it_toga1=INT(timeit/dt_toga)+1
+       it_toga2=it_toga1 + 1
+       time_toga1=(it_toga1-1)*dt_toga
+       time_toga2=(it_toga2-1)*dt_toga
+
+       if (it_toga1 .ge. nt_toga) then
+        write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: '            &
+     &        ,day,it_toga1,it_toga2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       frac=(time_toga2-timeit)/(time_toga2-time_toga1)
+       frac=max(frac,0.0)
+
+       ts_prof = ts_toga(it_toga2)                                         &
+     &          -frac*(ts_toga(it_toga2)-ts_toga(it_toga1))
+
+!        print*,
+!     :'day,annee_ref,day_ini_toga,timeit,it_toga1,it_toga2,SST:',
+!     :day,annee_ref,day_ini_toga,timeit/86400.,it_toga1,it_toga2,ts_prof
+
+       do k=1,nlev_toga
+        plev_prof(k) = 100.*(plev_toga(k,it_toga2)                         &
+     &          -frac*(plev_toga(k,it_toga2)-plev_toga(k,it_toga1)))
+        t_prof(k) = t_toga(k,it_toga2)                                     &
+     &          -frac*(t_toga(k,it_toga2)-t_toga(k,it_toga1))
+        q_prof(k) = q_toga(k,it_toga2)                                     &
+     &          -frac*(q_toga(k,it_toga2)-q_toga(k,it_toga1))
+        u_prof(k) = u_toga(k,it_toga2)                                     &
+     &          -frac*(u_toga(k,it_toga2)-u_toga(k,it_toga1))
+        v_prof(k) = v_toga(k,it_toga2)                                     &
+     &          -frac*(v_toga(k,it_toga2)-v_toga(k,it_toga1))
+        w_prof(k) = w_toga(k,it_toga2)                                     &
+     &          -frac*(w_toga(k,it_toga2)-w_toga(k,it_toga1))
+        ht_prof(k) = ht_toga(k,it_toga2)                                   &
+     &          -frac*(ht_toga(k,it_toga2)-ht_toga(k,it_toga1))
+        vt_prof(k) = vt_toga(k,it_toga2)                                   &
+     &          -frac*(vt_toga(k,it_toga2)-vt_toga(k,it_toga1))
+        hq_prof(k) = hq_toga(k,it_toga2)                                   &
+     &          -frac*(hq_toga(k,it_toga2)-hq_toga(k,it_toga1))
+        vq_prof(k) = vq_toga(k,it_toga2)                                   &
+     &          -frac*(vq_toga(k,it_toga2)-vq_toga(k,it_toga1))
+        enddo
+
+        return
+        END
+
+!======================================================================
+        SUBROUTINE interp_dice_time(day,day1,annee_ref                    &
+     &             ,year_ini_dice,day_ini_dice,nt_dice,dt_dice            &
+     &             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice       &
+     &             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice         &
+     &             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice     &
+     &             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof         &
+     &             ,ustar_prof,psurf_prof,ug_prof,vg_prof                 &
+     &             ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_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_dice: total nb of data in the forcing (e.g. 145 for Dice)
+! dt_dice: total time interval (in sec) between 2 forcing data (e.g. 30min. for Dice)
+!---------------------------------------------------------------------------------------
+
+#include "compar1d.h"
+
+! inputs:
+        integer annee_ref
+        integer nt_dice,nlev_dice
+        integer year_ini_dice
+        real day, day1,day_ini_dice,dt_dice
+        real shf_dice(nt_dice),lhf_dice(nt_dice),lwup_dice(nt_dice)
+        real swup_dice(nt_dice),tg_dice(nt_dice),ustar_dice(nt_dice)
+        real psurf_dice(nt_dice),ug_dice(nt_dice),vg_dice(nt_dice)
+        real ht_dice(nlev_dice,nt_dice),hq_dice(nlev_dice,nt_dice)
+        real hu_dice(nlev_dice,nt_dice),hv_dice(nlev_dice,nt_dice)
+        real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)
+! outputs:
+        real tg_prof,shf_prof,lhf_prof,lwup_prof,swup_prof
+        real ustar_prof,psurf_prof,ug_prof,vg_prof
+        real ht_prof(nlev_dice),hq_prof(nlev_dice)
+        real hu_prof(nlev_dice),hv_prof(nlev_dice)
+        real w_prof(nlev_dice),omega_prof(nlev_dice)
+! local:
+        integer it_dice1, it_dice2,k
+        real timeit,time_dice1,time_dice2,frac
+
+
+        if (forcing_type.eq.7) then
+! Check that initial day of the simulation consistent with Dice period:
+       print *,'annee_ref=',annee_ref
+       print *,'day1=',day1
+       print *,'day_ini_dice=',day_ini_dice
+       if (annee_ref.ne.1999) then
+        print*,'Pour Dice, annee_ref doit etre 1999'
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then
+        print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'
+        print*,'Changer dayref dans run.def',day1,day_ini_dice
+        stop
+       endif
+       if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then
+        print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'
+        print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice
+        stop
+       endif
+
+       endif
+
+! Determine timestep relative to the 1st day of TOGA-COARE:
+!       timeit=(day-day1)*86400.
+!       if (annee_ref.eq.1992) then
+!        timeit=(day-day_ini_dice)*86400.
+!       else
+!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+!       endif
+      timeit=(day-day_ini_dice)*86400
+
+! Determine the closest observation times:
+       it_dice1=INT(timeit/dt_dice)+1
+       it_dice2=it_dice1 + 1
+       time_dice1=(it_dice1-1)*dt_dice
+       time_dice2=(it_dice2-1)*dt_dice
+
+       if (it_dice1 .ge. nt_dice) then
+        write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       frac=(time_dice2-timeit)/(time_dice2-time_dice1)
+       frac=max(frac,0.0)
+
+       shf_prof = shf_dice(it_dice2)-frac*(shf_dice(it_dice2)-shf_dice(it_dice1))
+       lhf_prof = lhf_dice(it_dice2)-frac*(lhf_dice(it_dice2)-lhf_dice(it_dice1))
+       lwup_prof = lwup_dice(it_dice2)-frac*(lwup_dice(it_dice2)-lwup_dice(it_dice1))
+       swup_prof = swup_dice(it_dice2)-frac*(swup_dice(it_dice2)-swup_dice(it_dice1))
+       tg_prof = tg_dice(it_dice2)-frac*(tg_dice(it_dice2)-tg_dice(it_dice1))
+       ustar_prof = ustar_dice(it_dice2)-frac*(ustar_dice(it_dice2)-ustar_dice(it_dice1))
+       psurf_prof = psurf_dice(it_dice2)-frac*(psurf_dice(it_dice2)-psurf_dice(it_dice1))
+       ug_prof = ug_dice(it_dice2)-frac*(ug_dice(it_dice2)-ug_dice(it_dice1))
+       vg_prof = vg_dice(it_dice2)-frac*(vg_dice(it_dice2)-vg_dice(it_dice1))
+
+!        print*,
+!     :'day,annee_ref,day_ini_dice,timeit,it_dice1,it_dice2,SST:',
+!     :day,annee_ref,day_ini_dice,timeit/86400.,it_dice1,it_dice2,ts_prof
+
+       do k=1,nlev_dice
+        ht_prof(k) = ht_dice(k,it_dice2)-frac*(ht_dice(k,it_dice2)-ht_dice(k,it_dice1))
+        hq_prof(k) = hq_dice(k,it_dice2)-frac*(hq_dice(k,it_dice2)-hq_dice(k,it_dice1))
+        hu_prof(k) = hu_dice(k,it_dice2)-frac*(hu_dice(k,it_dice2)-hu_dice(k,it_dice1))
+        hv_prof(k) = hv_dice(k,it_dice2)-frac*(hv_dice(k,it_dice2)-hv_dice(k,it_dice1))
+        w_prof(k) = w_dice(k,it_dice2)-frac*(w_dice(k,it_dice2)-w_dice(k,it_dice1))
+        omega_prof(k) = omega_dice(k,it_dice2)-frac*(omega_dice(k,it_dice2)-omega_dice(k,it_dice1))
+        enddo
+
+        return
+        END
+
+!======================================================================
+        SUBROUTINE interp_armcu_time(day,day1,annee_ref                    &
+     &             ,year_ini_armcu,day_ini_armcu,nt_armcu,dt_armcu         &
+     &             ,nlev_armcu,fs_armcu,fl_armcu,at_armcu,rt_armcu         &
+     &             ,aqt_armcu,fs_prof,fl_prof,at_prof,rt_prof,aqt_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_armcu: total nb of data in the forcing (e.g. 31 for armcu)
+! dt_armcu: total time interval (in sec) between 2 forcing data (e.g. 1/2h for armcu)
+! fs= sensible flux
+! fl= latent flux
+! at,rt,aqt= advective and radiative tendencies
+!---------------------------------------------------------------------------------------
+
+! inputs:
+        integer annee_ref
+        integer nt_armcu,nlev_armcu
+        integer year_ini_armcu
+        real day, day1,day_ini_armcu,dt_armcu
+        real fs_armcu(nt_armcu),fl_armcu(nt_armcu),at_armcu(nt_armcu)
+        real rt_armcu(nt_armcu),aqt_armcu(nt_armcu)
+! outputs:
+        real fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
+! local:
+        integer it_armcu1, it_armcu2,k
+        real timeit,time_armcu1,time_armcu2,frac
+
+! Check that initial day of the simulation consistent with ARMCU period:
+       if (annee_ref.ne.1997 ) then
+        print*,'Pour ARMCU, annee_ref doit etre 1997 '
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+
+      timeit=(day-day_ini_armcu)*86400
+
+! Determine the closest observation times:
+       it_armcu1=INT(timeit/dt_armcu)+1
+       it_armcu2=it_armcu1 + 1
+       time_armcu1=(it_armcu1-1)*dt_armcu
+       time_armcu2=(it_armcu2-1)*dt_armcu
+       print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu
+       print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2',              &
+     &          it_armcu1,it_armcu2,time_armcu1,time_armcu2
+
+       if (it_armcu1 .ge. nt_armcu) then
+        write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: '          &
+     &        ,day,it_armcu1,it_armcu2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       frac=(time_armcu2-timeit)/(time_armcu2-time_armcu1)
+       frac=max(frac,0.0)
+
+       fs_prof = fs_armcu(it_armcu2)                                       &
+     &          -frac*(fs_armcu(it_armcu2)-fs_armcu(it_armcu1))
+       fl_prof = fl_armcu(it_armcu2)                                       &
+     &          -frac*(fl_armcu(it_armcu2)-fl_armcu(it_armcu1))
+       at_prof = at_armcu(it_armcu2)                                       &
+     &          -frac*(at_armcu(it_armcu2)-at_armcu(it_armcu1))
+       rt_prof = rt_armcu(it_armcu2)                                       &
+     &          -frac*(rt_armcu(it_armcu2)-rt_armcu(it_armcu1))
+       aqt_prof = aqt_armcu(it_armcu2)                                       &
+     &          -frac*(aqt_armcu(it_armcu2)-aqt_armcu(it_armcu1))
+
+         print*,                                                           &
+     &'day,annee_ref,day_ini_armcu,timeit,it_armcu1,it_armcu2,SST:',       &
+     &day,annee_ref,day_ini_armcu,timeit/86400.,it_armcu1,                 &
+     &it_armcu2,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
+
+        return
+        END
+
+!=====================================================================
+      subroutine readprofiles(nlev_max,kmax,ntrac,height,                  &
+     &           thlprof,qtprof,uprof,                                     &
+     &           vprof,e12prof,ugprof,vgprof,                              &
+     &           wfls,dqtdxls,dqtdyls,dqtdtls,                             &
+     &           thlpcar,tracer,nt1,nt2)
+      implicit none
+
+        integer nlev_max,kmax,kmax2,ntrac
+        logical :: llesread = .true.
+
+        real height(nlev_max),thlprof(nlev_max),qtprof(nlev_max),          &
+     &       uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max),            &
+     &       ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max),             &
+     &       dqtdxls(nlev_max),dqtdyls(nlev_max),dqtdtls(nlev_max),        &
+     &           thlpcar(nlev_max),tracer(nlev_max,ntrac)
+
+        integer, parameter :: ilesfile=1
+        integer :: ierr,k,itrac,nt1,nt2
+
+        if(.not.(llesread)) return
+
+       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
+        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
+        read (ilesfile,*) kmax
+        do k=1,kmax
+          read (ilesfile,*) height(k),thlprof(k),qtprof (k),               &
+     &                      uprof (k),vprof  (k),e12prof(k)
+        enddo
+        close(ilesfile)
+
+       open(ilesfile,file='lscale.inp.001',status='old',iostat=ierr)
+        if (ierr /= 0) stop 'ERROR:Lscale.inp does not exist'
+        read (ilesfile,*) kmax2
+        if (kmax .ne. kmax2) then
+          print *, 'fichiers prof.inp et lscale.inp incompatibles :'
+          print *, 'nbre de niveaux : ',kmax,' et ',kmax2
+          stop 'lecture profiles'
+        endif
+        do k=1,kmax
+          read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k),         &
+     &                      dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)
+        end do
+        close(ilesfile)
+
+       open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)
+        if (ierr /= 0) then
+            print*,'WARNING : trac.inp does not exist'
+        else
+        read (ilesfile,*) kmax2,nt1,nt2
+        if (nt2>ntrac) then
+          stop'Augmenter le nombre de traceurs dans traceur.def'
+        endif
+        if (kmax .ne. kmax2) then
+          print *, 'fichiers prof.inp et lscale.inp incompatibles :'
+          print *, 'nbre de niveaux : ',kmax,' et ',kmax2
+          stop 'lecture profiles'
+        endif
+        do k=1,kmax
+          read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)
+        end do
+        close(ilesfile)
+        endif
+
+        return
+        end
+!======================================================================
+      subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof,       &
+     &       thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)
+!======================================================================
+      implicit none
+
+        integer nlev_max,kmax
+        logical :: llesread = .true.
+
+        real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
+        real thlprof(nlev_max)
+        real qprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
+        real wprof(nlev_max),omega(nlev_max),o3mmr(nlev_max)
+
+        integer, parameter :: ilesfile=1
+        integer :: k,ierr
+
+        if(.not.(llesread)) return
+
+       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
+        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
+        read (ilesfile,*) kmax
+        do k=1,kmax
+          read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
+     &                      qprof (k),uprof(k),  vprof(k),  wprof(k),      &
+     &                      omega (k),o3mmr(k)
+        enddo
+        close(ilesfile)
+
+        return
+        end
+
+!======================================================================
+      subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof,       &
+     &    thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)
+!======================================================================
+      implicit none
+
+        integer nlev_max,kmax
+        logical :: llesread = .true.
+
+        real height(nlev_max),pprof(nlev_max),tprof(nlev_max),             &
+     &  thlprof(nlev_max),qlprof(nlev_max),qtprof(nlev_max),               &
+     &  qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max),                  &
+     &  wprof(nlev_max),tkeprof(nlev_max),o3mmr(nlev_max)
+
+        integer, parameter :: ilesfile=1
+        integer :: ierr,k
+
+        if(.not.(llesread)) return
+
+       open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
+        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
+        read (ilesfile,*) kmax
+        do k=1,kmax
+          read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
+     &                qvprof (k),qlprof (k),qtprof (k),                    &
+     &                uprof(k),  vprof(k),  wprof(k),tkeprof(k),o3mmr(k)
+        enddo
+        close(ilesfile)
+
+        return
+        end
+
+
+
+!======================================================================
+      subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof,       &
+     &       vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)
+!======================================================================
+      implicit none
+
+        integer nlev_max,kmax
+        logical :: llesread = .true.
+
+        real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
+        real thetaprof(nlev_max),rvprof(nlev_max)
+        real qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
+        real aprof(nlev_max+1),bprof(nlev_max+1)
+
+        integer, parameter :: ilesfile=1
+        integer, parameter :: ifile=2
+        integer :: ierr,jtot,k
+
+        if(.not.(llesread)) return
+
+! Read profiles at full levels
+       IF(nlev_max.EQ.19) THEN
+       open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)
+       print *,'On ouvre prof.inp.19'
+       ELSE
+       open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)
+       print *,'On ouvre prof.inp.40'
+       ENDIF
+        if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
+        read (ilesfile,*) kmax
+        do k=1,kmax
+          read (ilesfile,*) height(k)    ,pprof(k),  uprof(k), vprof(k),   &
+     &                      thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)
+        enddo
+        close(ilesfile)
+
+! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf) 
+       IF(nlev_max.EQ.19) THEN
+       open (ifile,file='proh.inp.19',status='old',iostat=ierr)
+       print *,'On ouvre proh.inp.19'
+       if (ierr /= 0) stop 'ERROR:Proh.inp.19 does not exist'
+       ELSE
+       open (ifile,file='proh.inp.40',status='old',iostat=ierr)
+       print *,'On ouvre proh.inp.40'
+       if (ierr /= 0) stop 'ERROR:Proh.inp.40 does not exist'
+       ENDIF
+        read (ifile,*) kmax
+        do k=1,kmax
+          read (ifile,*) jtot,aprof(k),bprof(k)
+        enddo
+        close(ifile)
+
+        return
+        end
+
+!=====================================================================
+      subroutine read_fire(fich_fire,nlevel,ntime                          &
+     &     ,zz,thl,qt,u,v,tke                                              &
+     &     ,ug,vg,wls,dqtdx,dqtdy,dqtdt,thl_rad)
+
+!program reading forcings of the FIRE case study
+
+
+      implicit none
+
+#include "netcdf.inc"
+
+      integer ntime,nlevel
+      character*80 :: fich_fire
+      real*8 zz(nlevel)
+
+      real*8 thl(nlevel)
+      real*8 qt(nlevel),u(nlevel)
+      real*8 v(nlevel),tke(nlevel)
+      real*8 ug(nlevel,ntime),vg(nlevel,ntime),wls(nlevel,ntime)
+      real*8 dqtdx(nlevel,ntime),dqtdy(nlevel,ntime)
+      real*8 dqtdt(nlevel,ntime),thl_rad(nlevel,ntime)
+
+      integer nid, ierr
+      integer nbvar3d
+      parameter(nbvar3d=30)
+      integer var3didin(nbvar3d)
+
+      ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: Pb opening forcings nc file '
+         write(*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+
+       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,"thetal",var3didin(2))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'temp'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"qt",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,"tke",var3didin(6))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'tke'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'ug'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vg'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"wls",var3didin(9))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'wls'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dqtdx'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dqtdy'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dqtdt'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'thl_rad'
+      endif
+!dimensions lecture
+!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture z ok',zz
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture thl ok',thl
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture qt ok',qt
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture u ok',u
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture v ok',v
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture tke ok',tke
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ug ok',ug
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vg ok',vg
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture wls ok',wls
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dqtdx ok',dqtdx
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dqtdy ok',dqtdy
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dqtdt ok',dqtdt
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture thl_rad ok',thl_rad
+
+         return 
+         end subroutine read_fire
+!=====================================================================
+      subroutine read_dice(fich_dice,nlevel,ntime                         &
+     &     ,zz,pres,th,qv,u,v,o3                                          &
+     &     ,shf,lhf,lwup,swup,tg,ustar,psurf,ug,vg                        &
+     &     ,hadvt,hadvq,hadvu,hadvv,w,omega)
+
+!program reading initial profils and forcings of the Dice case study
+
+
+      implicit none
+
+#include "netcdf.inc"
+
+      integer ntime,nlevel
+      integer l,k
+      character*80 :: fich_dice
+      real*8 time(ntime)
+      real*8 zz(nlevel)
+
+      real*8 th(nlevel),pres(nlevel)
+      real*8 qv(nlevel),u(nlevel),v(nlevel),o3(nlevel)
+      real*8 shf(ntime),lhf(ntime),lwup(ntime),swup(ntime),tg(ntime)
+      real*8 ustar(ntime),psurf(ntime),ug(ntime),vg(ntime)
+      real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime),hadvu(nlevel,ntime)
+      real*8 hadvv(nlevel,ntime),w(nlevel,ntime),omega(nlevel,ntime)
+
+      integer nid, ierr
+      integer nbvar3d
+      parameter(nbvar3d=30)
+      integer var3didin(nbvar3d)
+
+      ierr = NF_OPEN(fich_dice,NF_NOWRITE,nid)
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: Pb opening forcings nc file '
+         write(*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+
+       ierr=NF_INQ_VARID(nid,"height",var3didin(1)) 
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'height'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"pf",var3didin(11)) 
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'pf'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"theta",var3didin(12))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'theta'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"qv",var3didin(13))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'qv'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"u",var3didin(14))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'u'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"v",var3didin(15))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'o3'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"shf",var3didin(2))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'shf'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lhf'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lwup'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"swup",var3didin(5))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dqtdx'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'Tg'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'ustar'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'psurf'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'Ug'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'Vg'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hadvT'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hadvq'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hadvu'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hadvv'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"w",var3didin(21))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'w'
+      endif
+
+      ierr=NF_INQ_VARID(nid,"omega",var3didin(22))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'omega'
+      endif
+!dimensions lecture
+!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture zz ok',zz
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture pres ok',pres
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture th ok',th
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture qv ok',qv
+ 
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture u ok',u
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture v ok',v
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture o3 ok',o3
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture shf ok',shf
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture lhf ok',lhf
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture lwup ok',lwup
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture swup ok',swup
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture tg ok',tg
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ustar ok',ustar
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture psurf ok',psurf
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ug ok',ug
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vg ok',vg
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hadvt ok',hadvt
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hadvq ok',hadvq
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hadvu ok',hadvu
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hadvv ok',hadvv
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture w ok',w
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)
+#else
+         ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)
+#endif
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture omega ok',omega
+
+         return 
+         end subroutine read_dice
+!=====================================================================
+!     Reads CIRC input files      
+
+      SUBROUTINE read_circ(nlev_circ,cf,lwp,iwp,reliq,reice,t,z,p,pm,h2o,o3,sza)
+      
+      parameter (ncm_1=49180)
+#include "YOMCST.h"
+
+      real albsfc(ncm_1), albsfc_w(ncm_1)
+      real cf(nlev_circ), icefra(nlev_circ), deice(nlev_circ), &
+           reliq(nlev_circ), reice(nlev_circ), lwp(nlev_circ), iwp(nlev_circ)
+      real t(nlev_circ+1), z(nlev_circ+1), dz(nlev_circ), p(nlev_circ+1)
+      real aer_beta(nlev_circ), waer(nlev_circ), gaer(nlev_circ)
+      real pm(nlev_circ), tm(nlev_circ), h2o(nlev_circ), o3(nlev_circ)
+      real co2(nlev_circ), n2o(nlev_circ), co(nlev_circ), ch4(nlev_circ), &
+           o2(nlev_circ), ccl4(nlev_circ), f11(nlev_circ), f12(nlev_circ)
+!     za= zenital angle
+!     sza= cosinus angle zenital
+      real wavn(ncm_1), ssf(ncm_1),za,sza
+      integer nlev
+
+
+!     Open the files
+
+      open (11, file='Tsfc_sza_nlev_case.txt', status='old')
+      open (12, file='level_input_case.txt', status='old')
+      open (13, file='layer_input_case.txt', status='old')
+      open (14, file='aerosol_input_case.txt', status='old')
+      open (15, file='cloud_input_case.txt', status='old')
+      open (16, file='sfcalbedo_input_case.txt', status='old')
+      
+!     Read scalar information
+      do iskip=1,5
+         read (11, *)
+      enddo
+      read (11, '(i8)') nlev
+      read (11, '(f10.2)') tsfc
+      read (11, '(f10.2)') za
+      read (11, '(f10.4)') sw_dn_toa
+      sza=cos(za/180.*RPI)
+      print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI
+      close(11)
+
+!     Read level information
+      read (12, *)
+      do il=1,nlev
+         read (12, 302) ilev, z(il), p(il), t(il)
+         z(il)=z(il)*1000.    ! z donne en km
+         p(il)=p(il)*100.     ! p donne en mb
+      enddo
+302   format (i8, f8.3, 2f9.2)
+      close(12)
+
+!     Read layer information (midpoint values)
+      do iskip=1,3
+         read (13, *)
+      enddo
+      do il=1,nlev-1
+         read (13, 303) ilev,pm(il),tm(il),h2o(il),co2(il),o3(il), &
+                        n2o(il),co(il),ch4(il),o2(il),ccl4(il), &
+                        f11(il),f12(il)
+         pm(il)=pm(il)*100.
+      enddo
+303   format (i8, 2f9.2, 10(2x,e13.7))      
+      close(13)
+      
+!     Read aerosol layer information
+      do iskip=1,3
+         read (14, *)
+      enddo
+      read (14, '(f10.2)') aer_alpha
+      read (14, *)
+      read (14, *)
+      do il=1,nlev-1
+         read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)
+      enddo
+304   format (i8, f9.5, 2f8.3)
+      close(14)
+      
+!     Read cloud information
+      do iskip=1,3
+         read (15, *)
+      enddo
+      do il=1,nlev-1
+         read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)
+         lwp(il)=lwp(il)/1000.          ! lwp donne en g/kg
+         iwp(il)=iwp(il)/1000.          ! iwp donne en g/kg
+         reliq(il)=reliq(il)/1000000.   ! reliq donne en microns
+         reice(il)=reice(il)/1000000.   ! reice donne en microns
+      enddo
+305   format (i8, f8.3, 4f9.2)
+      close(15)
+
+!     Read surface albedo (weighted & unweighted) and spectral solar irradiance
+      do iskip=1,6
+         read (16, *)
+      enddo
+      do icm_1=1,ncm_1
+         read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)
+      enddo
+306   format(f10.1, 2f12.5, f14.8)
+      close(16)
+ 
+      return 
+      end subroutine read_circ
+!=====================================================================
+!     Reads RTMIP input files      
+
+      SUBROUTINE read_rtmip(nlev_rtmip,play,plev,t,h2o,o3)
+      
+#include "YOMCST.h"
+
+      real t(nlev_rtmip), pt(nlev_rtmip),pb(nlev_rtmip),h2o(nlev_rtmip), o3(nlev_rtmip)
+      real temp(nlev_rtmip), play(nlev_rtmip),ovap(nlev_rtmip), oz(nlev_rtmip),plev(nlev_rtmip+1)
+      integer nlev
+
+
+!     Open the files
+
+      open (11, file='low_resolution_profile.txt', status='old')
+      
+!     Read level information
+      read (11, *)
+      do il=1,nlev_rtmip
+         read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)
+      enddo
+      do il=1,nlev_rtmip
+         play(il)=pt(nlev_rtmip-il+1)*100.     ! p donne en mb
+         temp(il)=t(nlev_rtmip-il+1)
+         ovap(il)=h2o(nlev_rtmip-il+1)
+         oz(il)=o3(nlev_rtmip-il+1)
+      enddo
+      do il=1,39
+         plev(il)=play(il)+(play(il+1)-play(il))/2.
+         print *,'il p t ovap oz=',il,plev(il),temp(il),ovap(il),oz(il)
+      enddo
+      plev(41)=101300.
+302   format (e16.10,3x,e16.10,3x,e16.10,3x,e12.6,3x,e12.6)
+      close(12)
+ 
+      return 
+      end subroutine read_rtmip
+!=====================================================================
+
+!  Subroutines for nudging
+
+      Subroutine Nudge_RHT_init (paprs,pplay,t,q,t_targ,rh_targ)
+! ========================================================
+  USE dimphy
+
+  implicit none
+
+! ========================================================
+      REAL paprs(klon,klevp1)
+      REAL pplay(klon,klev)
+!
+!      Variables d'etat
+      REAL t(klon,klev)
+      REAL q(klon,klev)
+!
+!   Profiles cible
+      REAL t_targ(klon,klev)
+      REAL rh_targ(klon,klev)
+!
+   INTEGER k,i
+   REAL zx_qs
+
+! Declaration des constantes et des fonctions thermodynamiques
+!
+include "YOMCST.h"
+include "YOETHF.h"
+!
+!  ----------------------------------------
+!  Statement functions
+include "FCTTRE.h"
+!  ----------------------------------------
+!
+        DO k = 1,klev
+         DO i = 1,klon
+           t_targ(i,k) = t(i,k)
+           IF (t(i,k).LT.RTT) THEN
+              zx_qs = qsats(t(i,k))/(pplay(i,k))
+           ELSE
+              zx_qs = qsatl(t(i,k))/(pplay(i,k))
+           ENDIF
+           rh_targ(i,k) = q(i,k)/zx_qs
+         ENDDO
+        ENDDO
+      print *, 't_targ',t_targ
+      print *, 'rh_targ',rh_targ
+!
+!
+      RETURN
+      END
+
+      Subroutine Nudge_UV_init (paprs,pplay,u,v,u_targ,v_targ)
+! ========================================================
+  USE dimphy
+
+  implicit none
+
+! ========================================================
+      REAL paprs(klon,klevp1)
+      REAL pplay(klon,klev)
+!
+!      Variables d'etat
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+!
+!   Profiles cible
+      REAL u_targ(klon,klev)
+      REAL v_targ(klon,klev)
+!
+   INTEGER k,i
+!
+        DO k = 1,klev
+         DO i = 1,klon
+           u_targ(i,k) = u(i,k)
+           v_targ(i,k) = v(i,k)
+         ENDDO
+        ENDDO
+      print *, 'u_targ',u_targ
+      print *, 'v_targ',v_targ
+!
+!
+      RETURN
+      END
+
+      Subroutine Nudge_RHT (dtime,paprs,pplay,t_targ,rh_targ,t,q,          &
+     &                      d_t,d_q)
+! ========================================================
+  USE dimphy
+
+  implicit none
+
+! ========================================================
+      REAL dtime
+      REAL paprs(klon,klevp1)
+      REAL pplay(klon,klev)
+!
+!      Variables d'etat
+      REAL t(klon,klev)
+      REAL q(klon,klev)
+!
+! Tendances
+      REAL d_t(klon,klev)
+      REAL d_q(klon,klev)
+!
+!   Profiles cible
+      REAL t_targ(klon,klev)
+      REAL rh_targ(klon,klev)
+!
+!   Temps de relaxation
+      REAL tau
+!c      DATA tau /3600./
+!!      DATA tau /5400./
+      DATA tau /1800./
+!
+   INTEGER k,i
+   REAL zx_qs, rh, tnew, d_rh
+
+! Declaration des constantes et des fonctions thermodynamiques
+!
+include "YOMCST.h"
+include "YOETHF.h"
+!
+!  ----------------------------------------
+!  Statement functions
+include "FCTTRE.h"
+!  ----------------------------------------
+!
+        print *,'dtime, tau ',dtime,tau
+        print *, 't_targ',t_targ
+        print *, 'rh_targ',rh_targ
+        print *,'temp ',t
+        print *,'hum ',q
+        DO k = 1,klev
+         DO i = 1,klon
+!!           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
+            IF (t(i,k).LT.RTT) THEN
+               zx_qs = qsats(t(i,k))/(pplay(i,k))
+            ELSE
+               zx_qs = qsatl(t(i,k))/(pplay(i,k))
+            ENDIF
+            rh = q(i,k)/zx_qs
+!
+            d_t(i,k) = d_t(i,k) + 1./tau*(t_targ(i,k)-t(i,k))
+            d_rh = 1./tau*(rh_targ(i,k)-rh)
+!
+            tnew = t(i,k)+d_t(i,k)
+            IF (tnew.LT.RTT) THEN
+               zx_qs = qsats(tnew)/(pplay(i,k))
+            ELSE
+               zx_qs = qsatl(tnew)/(pplay(i,k))
+            ENDIF
+            d_q(i,k) = d_q(i,k) + d_rh*zx_qs
+!
+            print *,' k,d_t,rh,d_rh,d_q ',    &
+                      k,d_t(i,k),rh,d_rh,d_q(i,k)
+!!           ENDIF
+!
+         ENDDO
+        ENDDO
+!
+      RETURN
+      END
+
+      Subroutine Nudge_UV (dtime,paprs,pplay,u_targ,v_targ,u,v,          &
+     &                      d_u,d_v)
+! ========================================================
+  USE dimphy
+
+  implicit none
+
+! ========================================================
+      REAL dtime
+      REAL paprs(klon,klevp1)
+      REAL pplay(klon,klev)
+!
+!      Variables d'etat
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+!
+! Tendances
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+!
+!   Profiles cible
+      REAL u_targ(klon,klev)
+      REAL v_targ(klon,klev)
+!
+!   Temps de relaxation
+      REAL tau
+!c      DATA tau /3600./
+      DATA tau /5400./
+!
+   INTEGER k,i
+
+!
+        print *,'dtime, tau ',dtime,tau
+        print *, 'u_targ',u_targ
+        print *, 'v_targ',v_targ
+        print *,'zonal velocity ',u
+        print *,'meridional velocity ',v
+        DO k = 1,klev
+         DO i = 1,klon
+           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
+!
+            d_u(i,k) = d_u(i,k) + 1./tau*(u_targ(i,k)-u(i,k))
+            d_v(i,k) = d_v(i,k) + 1./tau*(v_targ(i,k)-v(i,k))
+!
+            print *,' k,u,d_u,v,d_v ',    &
+                      k,u(i,k),d_u(i,k),v(i,k),d_v(i,k)
+           ENDIF
+!
+         ENDDO
+        ENDDO
+!
+      RETURN
+      END
+
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_decl_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_decl_cases.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_decl_cases.h	(revision 2298)
@@ -0,0 +1,254 @@
+#include "netcdf.inc"
+
+! Declarations specifiques au cas Toga
+        character*80 :: fich_toga
+!        integer nlev_prof
+!        parameter (nlev_prof = 41)
+        integer nlev_toga, nt_toga
+        parameter (nlev_toga=41, nt_toga=480)
+        integer year_ini_toga, day_ini_toga, mth_ini_toga
+        real day_ju_ini_toga   ! Julian day of toga coare first day
+        parameter (year_ini_toga=1992) 
+        parameter (mth_ini_toga=11)
+        parameter (day_ini_toga=1)  !  1erNov1992
+        real dt_toga
+        parameter (dt_toga=6.*3600.)
+!!
+        integer year_print, month_print, day_print
+        real    sec_print
+!!
+        real ts_toga(nt_toga)
+        real plev_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)
+        real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)
+        real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)
+        real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
+        real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
+
+        real ts_prof
+        real plev_prof(nlev_toga),w_prof(nlev_toga)
+        real t_prof(nlev_toga),q_prof(nlev_toga)
+        real u_prof(nlev_toga),v_prof(nlev_toga)
+        real ht_prof(nlev_toga),vt_prof(nlev_toga)
+        real hq_prof(nlev_toga),vq_prof(nlev_toga)
+
+        real w_mod(llm), t_mod(llm),q_mod(llm)
+        real u_mod(llm),v_mod(llm), ht_mod(llm),vt_mod(llm)
+        real hq_mod(llm),vq_mod(llm),qv_mod(llm),ql_mod(llm),qt_mod(llm)
+        real th_mod(llm)
+
+        real ts_cur
+        common /sst_forcing/ts_cur ! also in read_tsurf1d.F
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Declarations specifiques au cas RICO
+        character*80 :: fich_rico
+        integer nlev_rico
+
+        parameter (nlev_rico=81)
+        real ts_rico,ps_rico
+        real w_rico(llm)
+        real t_rico(llm),q_rico(llm)
+        real u_rico(llm),v_rico(llm)
+        real dth_rico(llm)
+        real dqh_rico(llm)
+        real du_age(llm),dv_age(llm)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Declarations specifiques au cas TWPice
+        character*80 :: fich_twpice
+        integer nlev_twpi, nt_twpi
+        parameter (nlev_twpi=40, nt_twpi=215)
+        integer year_ini_twpi, day_ini_twpi, mth_ini_twpi
+        real heure_ini_twpi
+        real day_ju_ini_twpi   ! Julian day of twpice first day
+        parameter (year_ini_twpi=2006) 
+        parameter (mth_ini_twpi=1)
+        parameter (day_ini_twpi=17)  ! 17 = 17Jan2006
+        parameter (heure_ini_twpi=10800.) !3h en secondes
+        real dt_twpi
+        parameter (dt_twpi=3.*3600.)
+
+        real ts_twpi(nt_twpi)
+        real plev_twpi(nlev_twpi,nt_twpi),w_twpi(nlev_twpi,nt_twpi)
+        real t_twpi(nlev_twpi,nt_twpi),q_twpi(nlev_twpi,nt_twpi)
+        real u_twpi(nlev_twpi,nt_twpi),v_twpi(nlev_twpi,nt_twpi)
+        real ht_twpi(nlev_twpi,nt_twpi),vt_twpi(nlev_twpi,nt_twpi)
+        real hq_twpi(nlev_twpi,nt_twpi),vq_twpi(nlev_twpi,nt_twpi)
+
+        real ts_proftwp
+        real plev_proftwp(nlev_twpi),w_proftwp(nlev_twpi)
+        real t_proftwp(nlev_twpi),q_proftwp(nlev_twpi)
+        real u_proftwp(nlev_twpi),v_proftwp(nlev_twpi)
+        real ht_proftwp(nlev_twpi),vt_proftwp(nlev_twpi)
+        real hq_proftwp(nlev_twpi),vq_proftwp(nlev_twpi)
+
+
+
+!Declarations specifiques au cas FIRE
+        character*80 :: fich_fire
+        integer nlev_fire, nt_fire
+        parameter (nlev_fire=120, nt_fire=1)  
+        integer year_ini_fire, day_ini_fire, mth_ini_fire
+        real heure_ini_fire
+        parameter (year_ini_fire=1987) 
+        parameter (mth_ini_fire=7)
+        parameter (day_ini_fire=14)  ! 14 = 14Juil1987
+        parameter (heure_ini_fire=0.) !0h en secondes
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Declarations specifiques au cas DICE     (MPL 02072013)
+        character*80 :: fich_dice
+        integer nlev_dice, nt_dice
+        parameter (nlev_dice=70, nt_dice=145)  
+        integer year_ini_dice, day_ini_dice, mth_ini_dice
+        real heure_ini_dice
+        real day_ju_ini_dice   ! Julian day of dice first day
+        parameter (year_ini_dice=1999) 
+        parameter (mth_ini_dice=10)
+        parameter (day_ini_dice=23)  ! 23 = 23 october 1999
+        parameter (heure_ini_dice=68400.) !19UTC en secondes
+        real dt_dice
+        parameter (dt_dice=0.5*3600.) ! 1 forcage ttes les demi-heures
+
+!profils initiaux:
+        real plev_dice(nlev_dice)
+        
+        real zz_dice(nlev_dice)
+        real th_dice(nlev_dice),qv_dice(nlev_dice)
+        real u_dice(nlev_dice), v_dice(nlev_dice),o3_dice(nlev_dice)
+        real ht_dice(nlev_dice,nt_dice)
+        real hq_dice(nlev_dice,nt_dice), hu_dice(nlev_dice,nt_dice)
+        real hv_dice(nlev_dice,nt_dice)
+        real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)
+        real o3_mod(llm),hu_mod(llm),hv_mod(llm)
+        real th_dicei(nlev_dice),qv_dicei(nlev_dice)
+        real u_dicei(nlev_dice), v_dicei(nlev_dice),o3_dicei(nlev_dice)
+        real ht_dicei(nlev_dice)
+        real hq_dicei(nlev_dice), hu_dicei(nlev_dice)
+        real hv_dicei(nlev_dice)
+        real w_dicei(nlev_dice),omega_dicei(nlev_dice)
+
+        
+!forcings
+        real shf_dice(nt_dice),lhf_dice(nt_dice)
+        real lwup_dice(nt_dice),swup_dice(nt_dice)
+        real tg_dice(nt_dice),ustar_dice(nt_dice),psurf_dice(nt_dice)
+        real ug_dice(nt_dice),vg_dice(nt_dice)
+
+        real shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof
+        real ustar_prof,psurf_prof,cdrag
+        real ht_profd(nlev_dice),hq_profd(nlev_dice),hu_profd(nlev_dice)
+        real hv_profd(nlev_dice),w_profd(nlev_dice)
+        real omega_profd(nlev_dice),ug_profd,vg_profd
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Declarations specifiques au cas GCSSold
+        character*80 :: fich_gcssold_ctl
+        character*80 :: fich_gcssold_dat
+        real  ht_gcssold(llm),hq_gcssold(llm),hw_gcssold(llm)
+        real  hu_gcssold(llm)
+        real  hv_gcssold(llm)
+        real  hthturb_gcssold(llm)
+        real  hqturb_gcssold(llm)
+        real  Ts_gcssold
+        real  dtime_frcg
+        logical :: Turb_fcg_gcssold
+
+        common /turb_forcing/                                                   &
+     &  dtime_frcg,hthturb_gcssold, hqturb_gcssold,Turb_fcg_gcssold
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Declarations specifiques au cas Arm_cu
+        character*80 :: fich_armcu
+
+
+        integer nlev_armcu, nt_armcu
+        parameter (nlev_armcu=40, nt_armcu=31)
+        integer year_ini_armcu, day_ini_armcu, mth_ini_armcu
+        real  heure_ini_armcu
+        real day_ju_ini_armcu                                ! Julian day of armcu case first day
+        parameter (year_ini_armcu=1997) 
+        parameter (mth_ini_armcu=6)
+        parameter (day_ini_armcu=21)  ! 172 = 21 juin 1997
+        parameter (heure_ini_armcu=41400)   ! 11:30 en secondes
+        real dt_armcu
+        parameter (dt_armcu=1.*1800.)   ! forcages donnes ttes les demi-heures par ifa_armcu.txt
+        real sens_armcu(nt_armcu),flat_armcu(nt_armcu)
+        real adv_theta_armcu(nt_armcu),rad_theta_armcu(nt_armcu)
+        real adv_qt_armcu(nt_armcu)
+        real theta_mod(llm),rv_mod(llm),play_mod(llm)
+! profc comme "profil armcu"
+        
+! forcages interpoles dans le temps
+        real adv_theta_prof,rad_theta_prof,adv_qt_prof
+        real sens_prof,flat_prof,fact
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! declarations specifiques au cas Sandu
+        character*80 :: fich_sandu
+!        integer nlev_prof
+!        parameter (nlev_prof = 41)
+        integer nlev_sandu, nt_sandu
+        parameter (nlev_sandu=87, nt_sandu=13)
+        integer year_ini_sandu, day_ini_sandu, mth_ini_sandu
+        real day_ju_ini_sandu                                ! Julian day of sandu case first day
+        parameter (year_ini_sandu=2006)
+        parameter (mth_ini_sandu=7)
+        parameter (day_ini_sandu=15)  ! 196 = 15 juillet 2006
+        real dt_sandu, tau_sandu
+        logical  :: trouve_700=.true.
+        parameter (dt_sandu=6.*3600.)   ! forcages donnes ttes les 6 heures par ifa_sandu.txt
+        parameter (tau_sandu=3600.)  ! temps de relaxation u,v,thetal,qt vers profil init et au dessus 700hPa
+!!
+        real ts_sandu(nt_sandu)
+! profs comme "profil sandu"
+        real plev_profs(nlev_sandu)
+        real t_profs(nlev_sandu),thl_profs(nlev_sandu)
+        real q_profs(nlev_sandu)
+        real u_profs(nlev_sandu),v_profs(nlev_sandu),w_profs(nlev_sandu)
+        real omega_profs(nlev_sandu),o3mmr_profs(nlev_sandu)
+
+        real, dimension(llm) :: relax_u,relax_v,relax_thl
+        real, dimension(llm,2) :: relax_q
+
+        real thl_mod(llm),omega_mod(llm),o3mmr_mod(llm),tke_mod(llm)
+!vertical advection computation
+        real d_t_z(llm), d_q_z(llm)
+        real d_t_dyn_z(llm), d_q_dyn_z(llm)
+        real d_u_z(llm),d_v_z(llm)
+        real d_u_dyn(llm),d_v_dyn(llm)
+        real d_u_dyn_z(llm),d_v_dyn_z(llm)
+        real d_u_adv(llm),d_v_adv(llm)
+        real zz(llm)
+        real zfact
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Declarations specifiques au cas Astex
+        character*80 :: fich_astex
+        integer nlev_astex, nt_astex
+        parameter (nlev_astex=34, nt_astex=49)
+        integer year_ini_astex, day_ini_astex, mth_ini_astex
+        real day_ju_ini_astex                                ! Julian day of astex case first day
+        parameter (year_ini_astex=1992)
+        parameter (mth_ini_astex=6)
+        parameter (day_ini_astex=13)  ! 165 = 13 juin 1992
+        real dt_astex
+        parameter (dt_astex=3600.)    ! forcages donnes ttes les heures par ifa_astex.txt
+        real ts_astex(nt_astex),div_astex(nt_astex),ug_astex(nt_astex)
+        real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
+        real div_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
+! profa comme "profil astex"
+        real plev_profa(nlev_astex)
+        real t_profa(nlev_astex),thl_profa(nlev_astex)
+        real qv_profa(nlev_astex),ql_profa(nlev_astex)
+        real qt_profa(nlev_astex),o3mmr_profa(nlev_astex)
+        real u_profa(nlev_astex),v_profa(nlev_astex),w_profa(nlev_astex)
+        real tke_profa(nlev_astex)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Declarations specifiques au cas standard
+
+        real w_mod_cas(llm), t_mod_cas(llm),q_mod_cas(llm)
+        real ug_mod_cas(llm),vg_mod_cas(llm)
+        real u_mod_cas(llm),v_mod_cas(llm)
+        real ht_mod_cas(llm),vt_mod_cas(llm),dt_mod_cas(llm),dtrad_mod_cas(llm)
+        real hq_mod_cas(llm),vq_mod_cas(llm),dq_mod_cas(llm)
+        real hu_mod_cas(llm),vu_mod_cas(llm),du_mod_cas(llm)
+        real hv_mod_cas(llm),vv_mod_cas(llm),dv_mod_cas(llm)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_interp_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_interp_cases.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_interp_cases.h	(revision 2298)
@@ -0,0 +1,757 @@
+!---------------------------------------------------------------------
+! Interpolation forcing in time and onto model levels
+!---------------------------------------------------------------------
+      if (forcing_GCSSold) then
+
+       call get_uvd(it,timestep,fich_gcssold_ctl,fich_gcssold_dat,              &
+     &               ht_gcssold,hq_gcssold,hw_gcssold,                          &
+     &               hu_gcssold,hv_gcssold,                                     &
+     &               hthturb_gcssold,hqturb_gcssold,Ts_gcssold,                 &
+     &               imp_fcg_gcssold,ts_fcg_gcssold,                            &
+     &               Tp_fcg_gcssold,Turb_fcg_gcssold)
+       if (prt_level.ge.1) then
+         print *,' get_uvd -> hqturb_gcssold ',it,hqturb_gcssold
+       endif
+! large-scale forcing :
+!!!      tsurf = ts_gcssold
+      do l = 1, llm
+!       u(l) = hu_gcssold(l) !  on prescrit le vent
+!       v(l) = hv_gcssold(l)    !  on prescrit le vent
+!       omega(l) = hw_gcssold(l)
+!       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!       omega2(l)=-rho(l)*omega(l)
+       omega(l) = hw_gcssold(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+       d_th_adv(l) = ht_gcssold(l)
+       d_q_adv(l,1) = hq_gcssold(l)
+       dt_cooling(l) = 0.0
+      enddo
+
+      endif ! forcing_GCSSold
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation Toga forcing 
+!---------------------------------------------------------------------
+      if (forcing_toga) then
+
+       if (prt_level.ge.1) then
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_toga=',     &
+     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_toga
+       endif
+
+! time interpolation:
+        CALL interp_toga_time(daytime,day1,annee_ref                        &
+     &             ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga           &
+     &             ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga        &
+     &             ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga           &
+     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof    &
+     &             ,ht_prof,vt_prof,hq_prof,vq_prof)
+
+        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
+
+! vertical interpolation:
+      CALL interp_toga_vertical(play,nlev_toga,plev_prof                    &
+     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                          &
+     &         ,ht_prof,vt_prof,hq_prof,vq_prof                             &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+
+! large-scale forcing :
+      tsurf = ts_prof
+      do l = 1, llm
+       u(l) = u_mod(l) ! sb: on prescrit le vent
+       v(l) = v_mod(l) ! sb: on prescrit le vent
+!       omega(l) = w_prof(l)
+!       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!       omega2(l)=-rho(l)*omega(l)
+       omega(l) = w_mod(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+       d_th_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l))
+       d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l))
+       dt_cooling(l) = 0.0
+      enddo
+
+      endif ! forcing_toga
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Interpolation DICE forcing 
+!---------------------------------------------------------------------
+      if (forcing_dice) then
+
+       if (prt_level.ge.1) then
+        print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_dice=',&
+     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_dice
+       endif
+
+! time interpolation:
+      CALL interp_dice_time(daytime,day1,annee_ref                    &
+     &             ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice     & 
+     &             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice   &
+     &             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice     &
+     &             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice &
+     &             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof     &
+     &             ,ustar_prof,psurf_prof,ug_profd,vg_profd           &
+     &             ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd       &
+     &             ,omega_profd)
+!     do l = 1, llm
+!     print *,'llm l omega_profd',llm,l,omega_profd(l)
+!     enddo
+
+        if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d
+
+! vertical interpolation:
+      CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice        &
+     &         ,th_dice,qv_dice,u_dice,v_dice,o3_dice                   &
+     &         ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd,omega_profd &
+     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                        &
+     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
+!     do l = 1, llm
+!      print *,'llm l omega_mod',llm,l,omega_mod(l)
+!     enddo
+
+! Les forcages DICE sont donnes /jour et non /seconde !
+      ht_mod(:)=ht_mod(:)/86400.
+      hq_mod(:)=hq_mod(:)/86400.
+      hu_mod(:)=hu_mod(:)/86400.
+      hv_mod(:)=hv_mod(:)/86400.
+
+!calcul de l'advection verticale a partir du omega (repris cas TWPICE, MPL 05082013)
+!Calcul des gradients verticaux
+!initialisation
+      d_t_z(:)=0.
+      d_q_z(:)=0.
+      d_u_z(:)=0.
+      d_v_z(:)=0.
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
+       d_q_z(l)=(q(l+1,1)-q(l-1,1)) /(play(l+1)-play(l-1))
+       d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1))
+       d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1))
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+!     d_u_z(1)=u(2)/(play(2)-psurf)/5.
+!     d_v_z(1)=v(2)/(play(2)-psurf)/5.
+      d_u_z(1)=0.
+      d_v_z(1)=0.
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+      d_u_z(llm)=d_u_z(llm-1)
+      d_v_z(llm)=d_v_z(llm-1)
+
+!Calcul de l advection verticale: 
+! utiliser omega (Pa/s) et non w (m/s) !! MP 20131108
+      d_t_dyn_z(:)=omega_mod(:)*d_t_z(:)
+      d_q_dyn_z(:)=omega_mod(:)*d_q_z(:)
+      d_u_dyn_z(:)=omega_mod(:)*d_u_z(:)
+      d_v_dyn_z(:)=omega_mod(:)*d_v_z(:)
+
+! large-scale forcing :
+!     tsurf = tg_prof    MPL 20130925 commente
+      psurf = psurf_prof
+! For this case, fluxes are imposed
+      fsens=-1*shf_prof
+      flat=-1*lhf_prof
+      ust=ustar_prof
+      tg=tg_prof
+      print *,'ust= ',ust
+      do l = 1, llm
+       ug(l)= ug_profd
+       vg(l)= vg_profd
+!       omega(l) = w_prof(l)
+!      rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!       omega2(l)=-rho(l)*omega(l)
+!      omega(l) = w_mod(l)*(-rg*rho(l))
+       omega(l) = omega_mod(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l)
+       d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l)
+       d_u_adv(l) = hu_mod(l)-d_u_dyn_z(l)
+       d_v_adv(l) = hv_mod(l)-d_v_dyn_z(l)
+       dt_cooling(l) = 0.0
+      enddo
+
+      endif ! forcing_dice
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing TWPice
+!---------------------------------------------------------------------
+      if (forcing_twpice) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_twpi=',     &
+     &    daytime,day1,(daytime-day1)*86400.,                               &
+     &    (daytime-day1)*86400/dt_twpi
+
+! time interpolation:
+        CALL interp_toga_time(daytime,day1,annee_ref                        &
+     &       ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi       &
+     &       ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi          &
+     &       ,ht_twpi,vt_twpi,hq_twpi,vq_twpi                               &
+     &       ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp,u_proftwp         &
+     &       ,v_proftwp,w_proftwp                                           &
+     &       ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp)
+
+! vertical interpolation:
+      CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp                 &
+     &         ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp           &
+     &         ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp                 &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+
+
+!calcul de l'advection verticale a partir du omega
+!Calcul des gradients verticaux
+!initialisation
+      d_t_z(:)=0.
+      d_q_z(:)=0.
+      d_t_dyn_z(:)=0.
+      d_q_dyn_z(:)=0.
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
+       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+
+!Calcul de l advection verticale
+      d_t_dyn_z(:)=w_mod(:)*d_t_z(:)
+      d_q_dyn_z(:)=w_mod(:)*d_q_z(:)
+
+!wind nudging above 500m with a 2h time scale
+        do l=1,llm
+        if (nudge_wind) then
+!           if (phi(l).gt.5000.) then
+        if (phi(l).gt.0.) then
+        u(l)=u(l)+timestep*(u_mod(l)-u(l))/(2.*3600.)
+        v(l)=v(l)+timestep*(v_mod(l)-v(l))/(2.*3600.)
+           endif    
+        else
+        u(l) = u_mod(l) 
+        v(l) = v_mod(l)
+        endif
+        enddo
+
+!CR:nudging of q and theta with a 6h time scale above 15km
+        if (nudge_thermo) then
+        do l=1,llm
+           zz(l)=phi(l)/9.8
+           if ((zz(l).le.16000.).and.(zz(l).gt.15000.)) then
+             zfact=(zz(l)-15000.)/1000.
+        q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)*zfact
+        temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)*zfact
+           else if (zz(l).gt.16000.) then 
+        q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)
+        temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)
+           endif
+        enddo    
+        endif
+
+      do l = 1, llm
+       omega(l) = w_mod(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!calcul de l'advection totale
+        if (cptadvw) then
+        d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l)
+!        print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l)
+        d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l)
+!        print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l)
+        else
+        d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l))
+        d_q_adv(l,1) = (hq_mod(l)+vq_mod(l))
+        endif
+       dt_cooling(l) = 0.0
+      enddo
+
+      endif ! forcing_twpice
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing AMMA
+!---------------------------------------------------------------------
+
+       if (forcing_amma) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_amma=',     &
+     &    daytime,day1,(daytime-day1)*86400.,                               &
+     &    (daytime-day1)*86400/dt_amma
+
+! time interpolation using TOGA interpolation routine
+        CALL interp_amma_time(daytime,day1,annee_ref                        &
+     &       ,year_ini_amma,day_ju_ini_amma,nt_amma,dt_amma,nlev_amma       &
+     &       ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma                  &
+     &       ,vitw_profamma,ht_profamma,hq_profamma,lat_profamma            &
+     &       ,sens_profamma)
+
+      print*,'apres interpolation temporelle AMMA'
+
+      do k=1,nlev_amma
+         th_profamma(k)=0.
+         q_profamma(k)=0.
+         u_profamma(k)=0.
+         v_profamma(k)=0.
+         vt_profamma(k)=0.
+         vq_profamma(k)=0.
+       enddo
+! vertical interpolation using TOGA interpolation routine:
+!      write(*,*)'avant interp vert', t_proftwp
+      CALL interp_toga_vertical(play,nlev_amma,plev_amma                      &
+     &         ,th_profamma,q_profamma,u_profamma,v_profamma                 &
+     &         ,vitw_profamma                                               &
+     &         ,ht_profamma,vt_profamma,hq_profamma,vq_profamma             &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+       write(*,*) 'Profil initial forcing AMMA interpole'
+
+
+!calcul de l'advection verticale a partir du omega
+!Calcul des gradients verticaux
+!initialisation
+      do l=1,llm
+      d_t_z(l)=0.
+      d_q_z(l)=0.
+      enddo
+
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
+       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+
+
+      do l = 1, llm
+       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+       omega(l) = w_mod(l)*(-rg*rho(l))
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!calcul de l'advection totale
+!        d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-omega(l)*d_t_z(l)
+!attention: on impose dth
+        d_th_adv(l) = alpha*omega(l)/rcpd+                                  &
+     &         ht_mod(l)*(play(l)/pzero)**rkappa-omega(l)*d_t_z(l)
+!        d_th_adv(l) = 0.
+!        print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l)
+        d_q_adv(l,1) = hq_mod(l)-omega(l)*d_q_z(l)
+!        d_q_adv(l,1) = 0.
+!        print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l)
+   
+       dt_cooling(l) = 0.0
+      enddo
+
+
+!     ok_flux_surf=.false.
+      fsens=-1.*sens_profamma
+      flat=-1.*lat_profamma
+
+      endif ! forcing_amma
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing Rico
+!---------------------------------------------------------------------
+      if (forcing_rico) then
+!       call lstendH(llm,omega,dt_dyn,dq_dyn,du_dyn, dv_dyn,
+!     :  q,temp,u,v,play)
+       call lstendH(llm,nqtot,omega,dt_dyn,dq_dyn,q,temp,u,v,play)
+
+        do l=1,llm
+       d_th_adv(l) =  (dth_rico(l) +  dt_dyn(l))
+       d_q_adv(l,1) = (dqh_rico(l) +  dq_dyn(l,1))
+       d_q_adv(l,2) = 0.
+        enddo
+      endif  ! forcing_rico
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing Arm_cu
+!---------------------------------------------------------------------
+      if (forcing_armcu) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_armcu=',    &
+     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_armcu
+
+! time interpolation:
+! ATTENTION, cet appel ne convient pas pour TOGA !!
+! revoir 1DUTILS.h et les arguments
+      CALL interp_armcu_time(daytime,day1,annee_ref                         &
+     &            ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu        &
+     &            ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu          &
+     &            ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof         &
+     &            ,adv_theta_prof,rad_theta_prof,adv_qt_prof)
+
+! vertical interpolation:
+! No vertical interpolation if nlev imposed to 19 or 40
+
+! For this case, fluxes are imposed
+       fsens=-1*sens_prof
+       flat=-1*flat_prof
+
+! Advective forcings are given in K or g/kg ... BY HOUR
+      do l = 1, llm
+       ug(l)= u_mod(l)
+       vg(l)= v_mod(l)
+       IF((phi(l)/RG).LT.1000) THEN
+         d_th_adv(l) = (adv_theta_prof + rad_theta_prof)/3600.
+         d_q_adv(l,1) = adv_qt_prof/1000./3600.
+         d_q_adv(l,2) = 0.0
+!        print *,'INF1000: phi dth dq1 dq2',
+!    :  phi(l)/RG,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
+       ELSEIF ((phi(l)/RG).GE.1000.AND.(phi(l)/RG).lt.3000) THEN
+         fact=((phi(l)/RG)-1000.)/2000.
+         fact=1-fact
+         d_th_adv(l) = (adv_theta_prof + rad_theta_prof)*fact/3600.
+         d_q_adv(l,1) = adv_qt_prof*fact/1000./3600.
+         d_q_adv(l,2) = 0.0
+!        print *,'SUP1000: phi fact dth dq1 dq2',
+!    :  phi(l)/RG,fact,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
+       ELSE
+         d_th_adv(l) = 0.0
+         d_q_adv(l,1) = 0.0
+         d_q_adv(l,2) = 0.0
+!        print *,'SUP3000: phi dth dq1 dq2',
+!    :  phi(l)/RG,d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
+       ENDIF
+      dt_cooling(l) = 0.0  
+!     print *,'Interp armcu: phi dth dq1 dq2',
+!    :  l,phi(l),d_th_adv(l),d_q_adv(l,1),d_q_adv(l,2)
+      enddo
+      endif ! forcing_armcu
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing in time and onto model levels
+!---------------------------------------------------------------------
+      if (forcing_sandu) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_sandu=',    &
+     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_sandu 
+
+! time interpolation:
+! ATTENTION, cet appel ne convient pas pour TOGA !!
+! revoir 1DUTILS.h et les arguments
+      CALL interp_sandu_time(daytime,day1,annee_ref                         &
+     &             ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu       &
+     &             ,nlev_sandu                                              &
+     &             ,ts_sandu,ts_prof)
+
+        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
+
+! vertical interpolation:
+      CALL interp_sandu_vertical(play,nlev_sandu,plev_profs                 &
+     &         ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs           &
+     &         ,omega_profs,o3mmr_profs                                     &
+     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                       &
+     &         ,omega_mod,o3mmr_mod,mxcalc)
+!calcul de l'advection verticale
+!Calcul des gradients verticaux
+!initialisation
+      d_t_z(:)=0.
+      d_q_z(:)=0.
+      d_t_dyn_z(:)=0.
+      d_q_dyn_z(:)=0.
+! schema centre
+!     DO l=2,llm-1
+!      d_t_z(l)=(temp(l+1)-temp(l-1))
+!    &          /(play(l+1)-play(l-1))
+!      d_q_z(l)=(q(l+1,1)-q(l-1,1))
+!    &          /(play(l+1)-play(l-1))
+! schema amont
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l))
+       d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l))
+!     print *,'l temp2 temp0 play2 play0 omega_mod',
+!    & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l)
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+
+!  calcul de l advection verticale
+! Confusion w (m/s) et omega (Pa/s) !!
+      d_t_dyn_z(:)=omega_mod(:)*d_t_z(:)
+      d_q_dyn_z(:)=omega_mod(:)*d_q_z(:)
+!     do l=1,llm
+!      print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z',
+!    :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l)
+!     enddo
+
+
+! large-scale forcing : pour le cas Sandu ces forcages sont la SST
+! et une divergence constante -> profil de omega
+      tsurf = ts_prof
+      write(*,*) 'SST suivante: ',tsurf
+      do l = 1, llm
+       omega(l) = omega_mod(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!
+!      d_th_adv(l) = 0.0
+!      d_q_adv(l,1) = 0.0
+!CR:test advection=0
+!calcul de l'advection verticale
+        d_th_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l)
+!        print*,'temp adv',l,-d_t_dyn_z(l)
+        d_q_adv(l,1) = -d_q_dyn_z(l)
+!        print*,'q adv',l,-d_q_dyn_z(l)
+       dt_cooling(l) = 0.0
+      enddo
+      endif ! forcing_sandu
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing in time and onto model levels
+!---------------------------------------------------------------------
+      if (forcing_astex) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_astex=',    &
+     &    day,day1,(day-day1)*86400.,(day-day1)*86400/dt_astex
+
+! time interpolation:
+! ATTENTION, cet appel ne convient pas pour TOGA !!
+! revoir 1DUTILS.h et les arguments
+      CALL interp_astex_time(daytime,day1,annee_ref                         &
+     &             ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex       &
+     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex         &
+     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof    &
+     &             ,ufa_prof,vfa_prof)
+
+        if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d
+
+! vertical interpolation:
+      CALL interp_astex_vertical(play,nlev_astex,plev_profa                 &
+     &         ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa                &
+     &         ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa               &
+     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod        &
+     &         ,tke_mod,o3mmr_mod,mxcalc)
+!calcul de l'advection verticale
+!Calcul des gradients verticaux
+!initialisation
+      d_t_z(:)=0.
+      d_q_z(:)=0.
+      d_t_dyn_z(:)=0.
+      d_q_dyn_z(:)=0.
+! schema centre
+!     DO l=2,llm-1
+!      d_t_z(l)=(temp(l+1)-temp(l-1))
+!    &          /(play(l+1)-play(l-1))
+!      d_q_z(l)=(q(l+1,1)-q(l-1,1))
+!    &          /(play(l+1)-play(l-1))
+! schema amont
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l))
+       d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l))
+!     print *,'l temp2 temp0 play2 play0 omega_mod',
+!    & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l)
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+
+!  calcul de l advection verticale
+! Confusion w (m/s) et omega (Pa/s) !!
+      d_t_dyn_z(:)=w_mod(:)*d_t_z(:)
+      d_q_dyn_z(:)=w_mod(:)*d_q_z(:)
+!     do l=1,llm
+!      print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z',
+!    :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l)
+!     enddo
+
+
+! large-scale forcing : pour le cas Astex ces forcages sont la SST
+! la divergence,ug,vg,ufa,vfa
+      tsurf = ts_prof
+      write(*,*) 'SST suivante: ',tsurf
+      do l = 1, llm
+       omega(l) = w_mod(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!
+!      d_th_adv(l) = 0.0
+!      d_q_adv(l,1) = 0.0
+!CR:test advection=0
+!calcul de l'advection verticale
+        d_th_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l)
+!        print*,'temp adv',l,-d_t_dyn_z(l)
+        d_q_adv(l,1) = -d_q_dyn_z(l)
+!        print*,'q adv',l,-d_q_dyn_z(l)
+       dt_cooling(l) = 0.0
+      enddo
+      endif ! forcing_astex
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Interpolation forcing standard case
+!---------------------------------------------------------------------
+      if (forcing_case) then
+
+        print*,                                                             &
+     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=',     &
+     &    daytime,day1,(daytime-day1)*86400.,                               &
+     &    (daytime-day1)*86400/pdt_cas
+
+! time interpolation:
+        CALL interp_case_time(daytime,day1,annee_ref                        &
+     &       ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_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                 &
+     &       ,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)
+
+             ts_cur = ts_prof_cas 
+             psurf=plev_prof_cas(1)
+
+! vertical interpolation:
+      CALL interp_case_vertical(play,nlev_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           &
+     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
+
+
+!calcul de l'advection verticale a partir du omega
+!Calcul des gradients verticaux
+!initialisation
+      d_t_z(:)=0.
+      d_q_z(:)=0.
+      d_u_z(:)=0.
+      d_v_z(:)=0.
+      d_t_dyn_z(:)=0.
+      d_q_dyn_z(:)=0.
+      d_u_dyn_z(:)=0.
+      d_v_dyn_z(:)=0.
+      DO l=2,llm-1
+       d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
+       d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
+       d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1))
+       d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1))
+      ENDDO
+      d_t_z(1)=d_t_z(2)
+      d_q_z(1)=d_q_z(2)
+      d_u_z(1)=d_u_z(2)
+      d_v_z(1)=d_v_z(2)
+      d_t_z(llm)=d_t_z(llm-1)
+      d_q_z(llm)=d_q_z(llm-1)
+      d_u_z(llm)=d_u_z(llm-1)
+      d_v_z(llm)=d_v_z(llm-1)
+
+!Calcul de l advection verticale
+      d_t_dyn_z(:)=w_mod_cas(:)*d_t_z(:)
+      d_q_dyn_z(:)=w_mod_cas(:)*d_q_z(:)
+      d_u_dyn_z(:)=w_mod_cas(:)*d_u_z(:)
+      d_v_dyn_z(:)=w_mod_cas(:)*d_v_z(:)
+
+!wind nudging 
+      if (nudge_u.gt.0.) then
+        do l=1,llm
+           u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u)
+        enddo
+      else
+        do l=1,llm
+        u(l) = u_mod_cas(l) 
+        enddo
+      endif
+
+      if (nudge_v.gt.0.) then
+        do l=1,llm
+           v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v)
+        enddo
+      else
+        do l=1,llm
+        v(l) = v_mod_cas(l) 
+        enddo
+      endif
+
+      if (nudge_w.gt.0.) then
+        do l=1,llm
+           w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w)
+        enddo
+      else
+        do l=1,llm
+        w(l) = w_mod_cas(l) 
+        enddo
+      endif
+
+!nudging of q and temp 
+      if (nudge_t.gt.0.) then
+        do l=1,llm
+           temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t)
+        enddo
+      endif
+      if (nudge_q.gt.0.) then
+        do l=1,llm
+           q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q)
+        enddo
+      endif
+
+      do l = 1, llm
+       omega(l) = w_mod_cas(l)
+       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+
+!calcul advection
+        if ((tend_u.eq.1).and.(tend_w.eq.0)) then
+           d_u_adv(l)=du_mod_cas(l)
+        else if ((tend_u.eq.1).and.(tend_w.eq.1)) then
+           d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l)
+        endif
+
+        if ((tend_v.eq.1).and.(tend_w.eq.0)) then
+           d_v_adv(l)=dv_mod_cas(l)
+        else if ((tend_v.eq.1).and.(tend_w.eq.1)) then
+           d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l)
+        endif
+
+        if ((tend_t.eq.1).and.(tend_w.eq.0)) then
+!           d_th_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l)
+           d_th_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l)
+        else if ((tend_t.eq.1).and.(tend_w.eq.1)) then
+!           d_th_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l)
+           d_th_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l)
+        endif
+
+        if ((tend_q.eq.1).and.(tend_w.eq.0)) then
+!           d_q_adv(l,1)=dq_mod_cas(l)
+           d_q_adv(l,1)=-1*dq_mod_cas(l)
+        else if ((tend_q.eq.1).and.(tend_w.eq.1)) then
+!           d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l)
+           d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l)
+        endif
+         
+        if (tend_rayo.eq.1) then
+           dt_cooling(l) = dtrad_mod_cas(l)
+        else
+           dt_cooling(l) = 0.0
+        endif
+      enddo
+
+      endif ! forcing_case
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_nudge_sandu_astex.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_nudge_sandu_astex.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_nudge_sandu_astex.h	(revision 2298)
@@ -0,0 +1,34 @@
+      do l = 1, llm
+!
+! au dessus de 700hPa, on relaxe vers profil init
+!      on fait l'hypothese que dans ce cas, il n'y a plus d'eau liq. au dessus 700hpa
+!      donc la relaxation en thetal et qt devient relaxation en tempe et qv
+       relax_u(l)=(u(l)-u_mod(l))/tau_sandu  ! pour u et v on relaxe sur tte la colonne
+       relax_v(l)=(v(l)-v_mod(l))/tau_sandu
+       relax_q(l,1)=0.
+       relax_q(l,2)=0.
+       relax_thl(l)=0.
+!      print *,'nudge: l tau_sandu u u_mod',l,tau_sandu,u(l),u_mod(l)
+!
+       if (l.ge.llm700) then 
+         relax_q(l,1)=(q(l,1)-q_mod(l))/tau_sandu
+         relax_q(l,2)=0.
+         relax_thl(l)=(temp(l)-t_mod(l))/tau_sandu
+       endif
+!     print *,'l dq1 relax dqadv',l,dq(l,1),relax_q(l,1),d_q_adv(l,1)
+!     print *,'l dq2 relax dqadv',l,dq(l,2),relax_q(l,2),d_q_adv(l,2)
+!     print *,'l dt  relax dtadv',l,dt_phys(l),relax_thl(l),d_th_adv(l)
+      enddo
+        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &          
+     &              du_phys(1:mxcalc) - relax_u(1:mxcalc))
+        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                &
+     &               dv_phys(1:mxcalc) - relax_v(1:mxcalc))
+!       q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(
+!    .              dq(1:mxcalc,:) - relax_q(1:mxcalc,:)+
+!    .              d_q_adv(1:mxcalc,:))
+        q(1:mxcalc,1)=q(1:mxcalc,1)+timestep*(                              &
+     &      dq(1:mxcalc,1) - relax_q(1:mxcalc,1)+d_q_adv(1:mxcalc,1))
+        q(1:mxcalc,2)=q(1:mxcalc,2)+timestep*(                              &
+     &      dq(1:mxcalc,2) - relax_q(1:mxcalc,2)+d_q_adv(1:mxcalc,2))
+        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
+     &      dt_phys(1:mxcalc)-relax_thl(1:mxcalc)+d_th_adv(1:mxcalc))
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_read_forc_cases.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_read_forc_cases.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1D_read_forc_cases.h	(revision 2298)
@@ -0,0 +1,782 @@
+!----------------------------------------------------------------------
+! forcing_les = .T. : Impose a constant cooling 
+! forcing_radconv = .T. : Pure radiative-convective equilibrium:
+!----------------------------------------------------------------------
+
+
+      nq1=0
+      nq2=0
+
+      if (forcing_les .or. forcing_radconv                                      &
+     &    .or. forcing_GCSSold .or. forcing_fire) then
+
+      if (forcing_fire) then
+!----------------------------------------------------------------------
+!read fire forcings from fire.nc
+!----------------------------------------------------------------------
+      fich_fire='fire.nc'
+      call read_fire(fich_fire,nlev_fire,nt_fire                                &
+     &     ,height,tttprof,qtprof,uprof,vprof,e12prof                           &
+     &     ,ugprof,vgprof,wfls,dqtdxls                                          &
+     &     ,dqtdyls,dqtdtls,thlpcar)
+      write(*,*) 'Forcing FIRE lu'
+      kmax=120            ! nombre de niveaux dans les profils et forcages
+      else 
+!----------------------------------------------------------------------
+! Read profiles from files: prof.inp.001 and lscale.inp.001
+! (repris de readlesfiles)
+!----------------------------------------------------------------------
+
+      call readprofiles(nlev_max,kmax,nqtot,height,                             &
+     &           tttprof,qtprof,uprof,vprof,                                    &
+     &           e12prof,ugprof,vgprof,                                         &
+     &           wfls,dqtdxls,dqtdyls,dqtdtls,                                  &
+     &           thlpcar,qprof,nq1,nq2)
+      endif
+
+! compute altitudes of play levels.
+      zlay(1) =zsurf +  rd*tsurf*(psurf-play(1))/(rg*psurf)
+      do l = 2,llm
+        zlay(l) = zlay(l-1)+rd*tsurf*(psurf-play(1))/(rg*psurf)
+      enddo
+
+!----------------------------------------------------------------------
+! Interpolation of the profiles given on the input file to
+! model levels
+!----------------------------------------------------------------------
+      zlay(1) = zsurf +  rd*tsurf*(psurf-play(1))/(rg*psurf)
+      do l=1,llm
+        ! Above the max altutide of the input file
+
+        if (zlay(l)<height(kmax)) mxcalc=l
+
+        frac = (height(kmax)-zlay(l))/(height (kmax)-height(kmax-1))
+        ttt =tttprof(kmax)-frac*(tttprof(kmax)-tttprof(kmax-1))
+       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
+          temp(l) = ttt*(play(l)/pzero)**rkappa
+          teta(l) = ttt
+       else
+          temp(l) = ttt
+          teta(l) = ttt*(pzero/play(l))**rkappa
+       endif
+          print *,' temp,teta ',l,temp(l),teta(l)
+        q(l,1)  = qtprof(kmax)-frac*( qtprof(kmax)- qtprof(kmax-1))
+        u(l)    =  uprof(kmax)-frac*(  uprof(kmax)-  uprof(kmax-1))
+        v(l)    =  vprof(kmax)-frac*(  vprof(kmax)-  vprof(kmax-1))
+        ug(l)   = ugprof(kmax)-frac*( ugprof(kmax)- ugprof(kmax-1))
+        vg(l)   = vgprof(kmax)-frac*( vgprof(kmax)- vgprof(kmax-1))
+        IF (nq2>0) q(l,nq1:nq2)=qprof(kmax,nq1:nq2)                         &
+     &               -frac*(qprof(kmax,nq1:nq2)-qprof(kmax-1,nq1:nq2))
+        omega(l)=   wfls(kmax)-frac*(   wfls(kmax)-   wfls(kmax-1))
+
+        dq_dyn(l,1) = dqtdtls(kmax)-frac*(dqtdtls(kmax)-dqtdtls(kmax-1))
+        dt_cooling(l)=thlpcar(kmax)-frac*(thlpcar(kmax)-thlpcar(kmax-1))
+        do k=2,kmax
+          frac = (height(k)-zlay(l))/(height(k)-height(k-1))
+          if(l==1) print*,'k, height, tttprof',k,height(k),tttprof(k)
+          if(zlay(l)>height(k-1).and.zlay(l)<height(k)) then
+            ttt =tttprof(k)-frac*(tttprof(k)-tttprof(k-1))
+       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
+          temp(l) = ttt*(play(l)/pzero)**rkappa
+          teta(l) = ttt
+       else
+          temp(l) = ttt
+          teta(l) = ttt*(pzero/play(l))**rkappa
+       endif
+          print *,' temp,teta ',l,temp(l),teta(l)
+            q(l,1)  = qtprof(k)-frac*( qtprof(k)- qtprof(k-1))
+            u(l)    =  uprof(k)-frac*(  uprof(k)-  uprof(k-1))
+            v(l)    =  vprof(k)-frac*(  vprof(k)-  vprof(k-1))
+            ug(l)   = ugprof(k)-frac*( ugprof(k)- ugprof(k-1))
+            vg(l)   = vgprof(k)-frac*( vgprof(k)- vgprof(k-1))
+            IF (nq2>0) q(l,nq1:nq2)=qprof(k,nq1:nq2)                        &
+     &                   -frac*(qprof(k,nq1:nq2)-qprof(k-1,nq1:nq2))
+            omega(l)=   wfls(k)-frac*(   wfls(k)-   wfls(k-1))
+            dq_dyn(l,1)=dqtdtls(k)-frac*(dqtdtls(k)-dqtdtls(k-1))
+            dt_cooling(l)=thlpcar(k)-frac*(thlpcar(k)-thlpcar(k-1))
+          elseif(zlay(l)<height(1)) then ! profils uniformes pour z<height(1)
+            ttt =tttprof(1)
+       if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile
+          temp(l) = ttt*(play(l)/pzero)**rkappa
+          teta(l) = ttt
+       else
+          temp(l) = ttt
+          teta(l) = ttt*(pzero/play(l))**rkappa
+       endif
+            q(l,1)  = qtprof(1)
+            u(l)    =  uprof(1)
+            v(l)    =  vprof(1)
+            ug(l)   = ugprof(1)
+            vg(l)   = vgprof(1)
+            omega(l)=   wfls(1)
+            IF (nq2>0) q(l,nq1:nq2)=qprof(1,nq1:nq2)
+            dq_dyn(l,1)  =dqtdtls(1)
+            dt_cooling(l)=thlpcar(1)
+          endif
+        enddo 
+
+        temp(l)=max(min(temp(l),350.),150.)
+        rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+        if (l .lt. llm) then
+          zlay(l+1) = zlay(l) + (play(l)-play(l+1))/(rg*rho(l))
+        endif
+        omega2(l)=-rho(l)*omega(l)
+        omega(l)= omega(l)*(-rg*rho(l)) !en Pa/s
+        if (l>1) then
+        if(zlay(l-1)>height(kmax)) then
+           omega(l)=0.0
+           omega2(l)=0.0
+        endif   
+        endif
+        if(q(l,1)<0.) q(l,1)=0.0
+        q(l,2)  = 0.0
+      enddo
+
+      endif ! forcing_les .or. forcing_GCSSold .or. forcing_fire
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing for GCSSold:
+!---------------------------------------------------------------------
+      if (forcing_GCSSold) then
+       fich_gcssold_ctl = './forcing.ctl'
+       fich_gcssold_dat = './forcing8.dat'
+       call copie(llm,play,psurf,fich_gcssold_ctl)
+       call get_uvd2(it,timestep,fich_gcssold_ctl,fich_gcssold_dat,         &
+     &               ht_gcssold,hq_gcssold,hw_gcssold,                      &
+     &               hu_gcssold,hv_gcssold,                                 &
+     &               hthturb_gcssold,hqturb_gcssold,Ts_gcssold,             &
+     &               imp_fcg_gcssold,ts_fcg_gcssold,                        &
+     &               Tp_fcg_gcssold,Turb_fcg_gcssold)
+       print *,' get_uvd2 -> hqturb_gcssold ',hqturb_gcssold
+      endif ! forcing_GCSSold
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing for RICO:
+!---------------------------------------------------------------------
+      if (forcing_rico) then
+
+!       call writefield_phy('omega', omega,llm+1)
+      fich_rico = 'rico.txt'
+       call read_rico(fich_rico,nlev_rico,ps_rico,play                      &
+     &             ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico              &
+     &             ,dth_rico,dqh_rico)
+        print*, ' on a lu et prepare RICO'
+
+       mxcalc=llm
+       print *, airefi, ' airefi '
+       do l = 1, llm
+       rho(l)  = play(l)/(rd*t_rico(l)*(1.+(rv/rd-1.)*q_rico(l)))
+       temp(l) = t_rico(l)
+       q(l,1) = q_rico(l)
+       q(l,2) = 0.0
+       u(l) = u_rico(l)
+       v(l) = v_rico(l)
+       ug(l)=u_rico(l)
+       vg(l)=v_rico(l)
+       omega(l) = -w_rico(l)*rg
+       omega2(l) = omega(l)/rg*airefi
+       enddo
+      endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from TOGA-COARE experiment (Ciesielski et al. 2002) :
+!---------------------------------------------------------------------
+
+      if (forcing_toga) then
+
+! read TOGA-COARE forcing (native vertical grid, nt_toga timesteps):
+      fich_toga = './d_toga/ifa_toga_coare_v21_dime.txt'
+      CALL read_togacoare(fich_toga,nlev_toga,nt_toga                       &
+     &         ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga        &
+     &         ,ht_toga,vt_toga,hq_toga,vq_toga)
+
+       write(*,*) 'Forcing TOGA lu'
+
+! time interpolation for initial conditions:
+      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
+      CALL interp_toga_time(daytime,day1,annee_ref                          &
+     &             ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga           &
+     &             ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga        &
+     &             ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga           &
+     &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof    &
+     &             ,ht_prof,vt_prof,hq_prof,vq_prof)
+
+! vertical interpolation:
+      CALL interp_toga_vertical(play,nlev_toga,plev_prof                    &
+     &         ,t_prof,q_prof,u_prof,v_prof,w_prof                          &
+     &         ,ht_prof,vt_prof,hq_prof,vq_prof                             &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+       write(*,*) 'Profil initial forcing TOGA interpole'
+
+! initial and boundary conditions :
+      tsurf = ts_prof
+      write(*,*) 'SST initiale: ',tsurf
+      do l = 1, llm
+       temp(l) = t_mod(l)
+       q(l,1) = q_mod(l)
+       q(l,2) = 0.0
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       omega(l) = w_mod(l)
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+!?       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!?       omega2(l)=-rho(l)*omega(l)
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+       d_th_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l))
+       d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l))
+       d_q_adv(l,2) = 0.0
+      enddo
+
+      endif ! forcing_toga
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from TWPICE experiment (Shaocheng et al. 2010) :
+!---------------------------------------------------------------------
+
+      if (forcing_twpice) then
+!read TWP-ICE forcings
+     fich_twpice='d_twpi/twp180iopsndgvarana_v2.1_C3.c1.20060117.000000.cdf'
+      call read_twpice(fich_twpice,nlev_twpi,nt_twpi                        &
+     &     ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi            &
+     &     ,ht_twpi,vt_twpi,hq_twpi,vq_twpi)
+
+      write(*,*) 'Forcing TWP-ICE lu'
+!Time interpolation for initial conditions using TOGA interpolation routine
+         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
+      CALL interp_toga_time(daytime,day1,annee_ref                          &
+     &          ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi    &
+     &             ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi    &
+     &             ,ht_twpi,vt_twpi,hq_twpi,vq_twpi                         &
+     &             ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp             &
+     &             ,u_proftwp,v_proftwp,w_proftwp                           &
+     &             ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp)
+
+! vertical interpolation using TOGA interpolation routine:
+!      write(*,*)'avant interp vert', t_proftwp
+      CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp                 &
+     &         ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp           &
+     &         ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp                 &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+!       write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod
+
+! initial and boundary conditions :
+!      tsurf = ts_proftwp
+      write(*,*) 'SST initiale: ',tsurf
+      do l = 1, llm
+       temp(l) = t_mod(l)
+       q(l,1) = q_mod(l)
+       q(l,2) = 0.0
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       omega(l) = w_mod(l)
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!on applique le forcage total au premier pas de temps
+!attention: signe different de toga
+       d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l))
+       d_q_adv(l,1) = (hq_mod(l)+vq_mod(l))
+       d_q_adv(l,2) = 0.0
+      enddo     
+       
+      endif !forcing_twpice
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from AMMA experiment (Couvreux et al. 2010) :
+!---------------------------------------------------------------------
+
+      if (forcing_amma) then
+
+      call read_1D_cases
+
+      write(*,*) 'Forcing AMMA lu'
+
+!champs initiaux:
+      do k=1,nlev_amma
+         th_ammai(k)=th_amma(k)
+         q_ammai(k)=q_amma(k)
+         u_ammai(k)=u_amma(k)
+         v_ammai(k)=v_amma(k)
+         vitw_ammai(k)=vitw_amma(k,12)
+         ht_ammai(k)=ht_amma(k,12)
+         hq_ammai(k)=hq_amma(k,12)
+         vt_ammai(k)=0.
+         vq_ammai(k)=0.
+      enddo   
+      omega(:)=0.      
+      omega2(:)=0.
+      rho(:)=0.
+! vertical interpolation using TOGA interpolation routine:
+!      write(*,*)'avant interp vert', t_proftwp
+      CALL interp_toga_vertical(play,nlev_amma,plev_amma                    &
+     &         ,th_ammai,q_ammai,u_ammai,v_ammai,vitw_ammai                 &
+     &         ,ht_ammai,vt_ammai,hq_ammai,vq_ammai                         &
+     &         ,t_mod,q_mod,u_mod,v_mod,w_mod                               &
+     &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
+!       write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod
+
+! initial and boundary conditions :
+!      tsurf = ts_proftwp
+      write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc
+      do l = 1, llm
+! Ligne du dessous à decommenter si on lit theta au lieu de temp
+!      temp(l) = t_mod(l)*(play(l)/pzero)**rkappa 
+       temp(l) = t_mod(l) 
+       q(l,1) = q_mod(l)
+       q(l,2) = 0.0
+!      print *,'read_forc: l,temp,q=',l,temp(l),q(l,1)
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+       omega(l) = w_mod(l)*(-rg*rho(l))
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!on applique le forcage total au premier pas de temps
+!attention: signe different de toga
+       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)
+!forcage en th
+!       d_th_adv(l) = ht_mod(l)
+       d_q_adv(l,1) = hq_mod(l)
+       d_q_adv(l,2) = 0.0
+       dt_cooling(l)=0.
+      enddo     
+       write(*,*) 'Prof initeforcing AMMA interpole temp39',temp(39)
+      
+
+!     ok_flux_surf=.false.
+      fsens=-1.*sens_amma(12)
+      flat=-1.*lat_amma(12)
+       
+      endif !forcing_amma
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from DICE experiment (see file DICE_protocol_vn2-3.pdf)
+!---------------------------------------------------------------------
+
+      if (forcing_dice) then
+!read DICE forcings
+      fich_dice='dice_driver.nc'
+      call read_dice(fich_dice,nlev_dice,nt_dice                    &
+     &     ,zz_dice,plev_dice,th_dice,qv_dice,u_dice,v_dice,o3_dice &
+     &     ,shf_dice,lhf_dice,lwup_dice,swup_dice,tg_dice,ustar_dice& 
+     &     ,psurf_dice,ug_dice,vg_dice,ht_dice,hq_dice              &
+     &     ,hu_dice,hv_dice,w_dice,omega_dice)
+
+      write(*,*) 'Forcing DICE lu'
+
+!champs initiaux:
+      do k=1,nlev_dice
+         th_dicei(k)=th_dice(k)
+         qv_dicei(k)=qv_dice(k)
+         u_dicei(k)=u_dice(k)
+         v_dicei(k)=v_dice(k)
+         o3_dicei(k)=o3_dice(k)
+         ht_dicei(k)=ht_dice(k,1)
+         hq_dicei(k)=hq_dice(k,1)
+         hu_dicei(k)=hu_dice(k,1)
+         hv_dicei(k)=hv_dice(k,1)
+         w_dicei(k)=w_dice(k,1)
+         omega_dicei(k)=omega_dice(k,1)
+      enddo   
+      omega(:)=0.      
+      omega2(:)=0.
+      rho(:)=0.
+! vertical interpolation using TOGA interpolation routine:
+!      write(*,*)'avant interp vert', t_proftwp
+!
+!     CALL interp_dice_time(daytime,day1,annee_ref
+!    i             ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice
+!    i             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice
+!    i             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice
+!    i             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice
+!    o             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof
+!    o             ,ustar_prof,psurf_prof,ug_profd,vg_profd
+!    o             ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd
+!    o             ,omega_profd)
+
+      CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice       &
+     &         ,th_dicei,qv_dicei,u_dicei,v_dicei,o3_dicei             &
+     &         ,ht_dicei,hq_dicei,hu_dicei,hv_dicei,w_dicei,omega_dicei&
+     &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                       &
+     &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
+
+! Pour tester les advections horizontales de T et Q, on met w_mod et omega_mod à zero (MPL 20131108)
+!     w_mod(:,:)=0.
+!     omega_mod(:,:)=0.
+
+!       write(*,*) 'Profil initial forcing DICE interpole',t_mod
+! Les forcages DICE sont donnes /jour et non /seconde !
+      ht_mod(:)=ht_mod(:)/86400.
+      hq_mod(:)=hq_mod(:)/86400.
+      hu_mod(:)=hu_mod(:)/86400.
+      hv_mod(:)=hv_mod(:)/86400.
+
+! initial and boundary conditions :
+      write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc
+      do l = 1, llm
+! Ligne du dessous à decommenter si on lit theta au lieu de temp
+       temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 
+!      temp(l) = t_mod(l) 
+       q(l,1) = qv_mod(l)
+       q(l,2) = 0.0
+!      print *,'read_forc: l,temp,q=',l,temp(l),q(l,1)
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       ug(l)=ug_dice(1)
+       vg(l)=vg_dice(1)
+       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!      omega(l) = w_mod(l)*(-rg*rho(l))
+       omega(l) = omega_mod(l)
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!on applique le forcage total au premier pas de temps
+!attention: signe different de toga
+       d_th_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)
+!forcage en th
+!       d_th_adv(l) = ht_mod(l)
+       d_q_adv(l,1) = hq_mod(l)
+       d_q_adv(l,2) = 0.0
+       dt_cooling(l)=0.
+      enddo     
+       write(*,*) 'Profil initial forcing DICE interpole temp39',temp(39)
+      
+
+!     ok_flux_surf=.false.
+      fsens=-1.*shf_dice(1)
+      flat=-1.*lhf_dice(1)
+! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 
+! le coefficient de trainee en surface cd**2=ustar*vent(k=1)
+! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface
+! MPL 05082013
+      ust=ustar_dice(1)
+      tg=tg_dice(1)
+      print *,'ust= ',ust
+      IF (tsurf .LE. 0.) THEN
+       tsurf= tg_dice(1)
+      ENDIF
+      psurf= psurf_dice(1)
+      solsw_in = (1.-albedo)/albedo*swup_dice(1)
+      sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1)
+      PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in
+      endif !forcing_dice
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from Arm_Cu case                   
+! For this case, ifa_armcu.txt contains sensible, latent heat fluxes
+! large scale advective forcing,radiative forcing 
+! and advective tendency of theta and qt to be applied 
+!---------------------------------------------------------------------
+
+      if (forcing_armcu) then
+! read armcu forcing :
+       write(*,*) 'Avant lecture Forcing Arm_Cu'
+      fich_armcu = './ifa_armcu.txt'
+      CALL read_armcu(fich_armcu,nlev_armcu,nt_armcu,                       &
+     & sens_armcu,flat_armcu,adv_theta_armcu,                               &
+     & rad_theta_armcu,adv_qt_armcu)
+       write(*,*) 'Forcing Arm_Cu lu'
+
+!----------------------------------------------------------------------
+! Read profiles from file: prof.inp.19 or prof.inp.40 
+! For this case, profiles are given for two vertical resolution
+! 19 or 40 levels
+!
+! Comment from: http://www.knmi.nl/samenw/eurocs/ARM/profiles.html
+! Note that the initial profiles contain no liquid water! 
+! (so potential temperature can be interpreted as liquid water 
+! potential temperature and water vapor as total water)
+! profiles are given at full levels
+!----------------------------------------------------------------------
+
+      call readprofile_armcu(nlev_max,kmax,height,play_mod,u_mod,           &
+     &           v_mod,theta_mod,t_mod,qv_mod,rv_mod,ap,bp)
+
+! time interpolation for initial conditions:
+      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
+
+      print *,'Avant interp_armcu_time'
+      print *,'daytime=',daytime
+      print *,'day1=',day1
+      print *,'annee_ref=',annee_ref
+      print *,'year_ini_armcu=',year_ini_armcu
+      print *,'day_ju_ini_armcu=',day_ju_ini_armcu
+      print *,'nt_armcu=',nt_armcu
+      print *,'dt_armcu=',dt_armcu
+      print *,'nlev_armcu=',nlev_armcu
+      CALL interp_armcu_time(daytime,day1,annee_ref                         &
+     &            ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu        &
+     &            ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu         &
+     &            ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof         &
+     &            ,adv_theta_prof,rad_theta_prof,adv_qt_prof)
+       write(*,*) 'Forcages interpoles dans temps'
+
+! No vertical interpolation if nlev imposed to 19 or 40
+! The vertical grid stops at 4000m # 600hPa
+      mxcalc=llm
+
+! initial and boundary conditions :
+!     tsurf = ts_prof
+! tsurf read in lmdz1d.def
+      write(*,*) 'Tsurf initiale: ',tsurf
+      do l = 1, llm
+       play(l)=play_mod(l)*100.
+       presnivs(l)=play(l)
+       zlay(l)=height(l)
+       temp(l) = t_mod(l)
+       teta(l)=theta_mod(l)
+       q(l,1) = qv_mod(l)/1000.
+! No liquid water in the initial profil
+       q(l,2) = 0.
+       u(l) = u_mod(l)
+       ug(l)= u_mod(l)
+       v(l) = v_mod(l)
+       vg(l)= v_mod(l)
+! Advective forcings are given in K or g/kg ... per HOUR
+!      IF(height(l).LT.1000) THEN
+!        d_th_adv(l) = (adv_theta_prof + rad_theta_prof)/3600.
+!        d_q_adv(l,1) = adv_qt_prof/1000./3600.
+!        d_q_adv(l,2) = 0.0
+!      ELSEIF (height(l).GE.1000.AND.height(l).LT.3000) THEN
+!        d_th_adv(l) = (adv_theta_prof + rad_theta_prof)*
+!    :               (1-(height(l)-1000.)/2000.)
+!        d_th_adv(l) = d_th_adv(l)/3600.
+!        d_q_adv(l,1) = adv_qt_prof*(1-(height(l)-1000.)/2000.)
+!        d_q_adv(l,1) = d_q_adv(l,1)/1000./3600.
+!        d_q_adv(l,2) = 0.0
+!      ELSE
+!        d_th_adv(l) = 0.0
+!        d_q_adv(l,1) = 0.0
+!        d_q_adv(l,2) = 0.0
+!      ENDIF
+      enddo
+! plev at half levels is given in proh.inp.19 or proh.inp.40 files
+      plev(1)= ap(llm+1)+bp(llm+1)*psurf
+      do l = 1, llm
+      plev(l+1) = ap(llm-l+1)+bp(llm-l+1)*psurf
+      print *,'Read_forc: l height play plev zlay temp',                    &
+     &   l,height(l),play(l),plev(l),zlay(l),temp(l)
+      enddo
+! For this case, fluxes are imposed
+       fsens=-1*sens_prof
+       flat=-1*flat_prof
+
+      endif ! forcing_armcu
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from transition case of Irina Sandu                  
+!---------------------------------------------------------------------
+
+      if (forcing_sandu) then
+       write(*,*) 'Avant lecture Forcing SANDU'
+
+! read sanduref forcing :
+      fich_sandu = './ifa_sanduref.txt'
+      CALL read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
+
+       write(*,*) 'Forcing SANDU lu'
+
+!----------------------------------------------------------------------
+! Read profiles from file: prof.inp.001 
+!----------------------------------------------------------------------
+
+      call readprofile_sandu(nlev_max,kmax,height,plev_profs,t_profs,       &
+     &           thl_profs,q_profs,u_profs,v_profs,                         &
+     &           w_profs,omega_profs,o3mmr_profs)
+
+! time interpolation for initial conditions:
+      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
+! ATTENTION, cet appel ne convient pas pour le cas SANDU !!
+! revoir 1DUTILS.h et les arguments
+
+      print *,'Avant interp_sandu_time'
+      print *,'daytime=',daytime
+      print *,'day1=',day1
+      print *,'annee_ref=',annee_ref
+      print *,'year_ini_sandu=',year_ini_sandu
+      print *,'day_ju_ini_sandu=',day_ju_ini_sandu
+      print *,'nt_sandu=',nt_sandu
+      print *,'dt_sandu=',dt_sandu
+      print *,'nlev_sandu=',nlev_sandu
+      CALL interp_sandu_time(daytime,day1,annee_ref                         &
+     &             ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu       &
+     &             ,nlev_sandu                                              &
+     &             ,ts_sandu,ts_prof)
+
+! vertical interpolation:
+      print *,'Avant interp_vertical: nlev_sandu=',nlev_sandu
+      CALL interp_sandu_vertical(play,nlev_sandu,plev_profs                 &
+     &         ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs           &
+     &         ,omega_profs,o3mmr_profs                                     &
+     &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                       &
+     &         ,omega_mod,o3mmr_mod,mxcalc)
+       write(*,*) 'Profil initial forcing SANDU interpole'
+
+! initial and boundary conditions :
+      tsurf = ts_prof
+      write(*,*) 'SST initiale: ',tsurf
+      do l = 1, llm
+       temp(l) = t_mod(l)
+       tetal(l)=thl_mod(l)
+       q(l,1) = q_mod(l)
+       q(l,2) = 0.0
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       w(l) = w_mod(l)
+       omega(l) = omega_mod(l)
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+!?       rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!?       omega2(l)=-rho(l)*omega(l)
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!      d_th_adv(l) = alpha*omega(l)/rcpd+vt_mod(l)
+!      d_q_adv(l,1) = vq_mod(l)
+       d_th_adv(l) = alpha*omega(l)/rcpd
+       d_q_adv(l,1) = 0.0
+       d_q_adv(l,2) = 0.0
+      enddo
+
+      endif ! forcing_sandu
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from Astex case
+!---------------------------------------------------------------------
+
+      if (forcing_astex) then
+       write(*,*) 'Avant lecture Forcing Astex'
+
+! read astex forcing :
+      fich_astex = './ifa_astex.txt'
+      CALL read_astex(fich_astex,nlev_astex,nt_astex,div_astex,ts_astex,    &
+     &  ug_astex,vg_astex,ufa_astex,vfa_astex)
+
+       write(*,*) 'Forcing Astex lu'
+
+!----------------------------------------------------------------------
+! Read profiles from file: prof.inp.001
+!----------------------------------------------------------------------
+
+      call readprofile_astex(nlev_max,kmax,height,plev_profa,t_profa,       &
+     &           thl_profa,qv_profa,ql_profa,qt_profa,u_profa,v_profa,      &
+     &           w_profa,tke_profa,o3mmr_profa)
+
+! time interpolation for initial conditions:
+      write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1
+! ATTENTION, cet appel ne convient pas pour le cas SANDU !!
+! revoir 1DUTILS.h et les arguments
+
+      print *,'Avant interp_astex_time'
+      print *,'daytime=',daytime
+      print *,'day1=',day1
+      print *,'annee_ref=',annee_ref
+      print *,'year_ini_astex=',year_ini_astex
+      print *,'day_ju_ini_astex=',day_ju_ini_astex
+      print *,'nt_astex=',nt_astex
+      print *,'dt_astex=',dt_astex
+      print *,'nlev_astex=',nlev_astex
+      CALL interp_astex_time(daytime,day1,annee_ref                         &
+     &             ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex       &
+     &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex         &
+     &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof    &
+     &             ,ufa_prof,vfa_prof)
+
+! vertical interpolation:
+      print *,'Avant interp_vertical: nlev_astex=',nlev_astex
+      CALL interp_astex_vertical(play,nlev_astex,plev_profa                 &
+     &         ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa                &
+     &         ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa               &
+     &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod        &
+     &         ,tke_mod,o3mmr_mod,mxcalc)
+       write(*,*) 'Profil initial forcing Astex interpole'
+
+! initial and boundary conditions :
+      tsurf = ts_prof
+      write(*,*) 'SST initiale: ',tsurf
+      do l = 1, llm
+       temp(l) = t_mod(l)
+       tetal(l)=thl_mod(l)
+       q(l,1) = qv_mod(l)
+       q(l,2) = ql_mod(l)
+       u(l) = u_mod(l)
+       v(l) = v_mod(l)
+       w(l) = w_mod(l)
+       omega(l) = w_mod(l)
+!      omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+!      rho(l)  = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1)))
+!      omega2(l)=-rho(l)*omega(l)
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!      d_th_adv(l) = alpha*omega(l)/rcpd+vt_mod(l)
+!      d_q_adv(l,1) = vq_mod(l)
+       d_th_adv(l) = alpha*omega(l)/rcpd
+       d_q_adv(l,1) = 0.0
+       d_q_adv(l,2) = 0.0
+      enddo
+
+      endif ! forcing_astex
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!---------------------------------------------------------------------
+! Forcing from standard case :
+!---------------------------------------------------------------------
+
+      if (forcing_case) then
+
+         write(*,*),'avant call read_1D_cas'
+         call read_1D_cas
+         write(*,*) 'Forcing read'
+
+!Time interpolation for initial conditions using TOGA interpolation routine
+         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
+      CALL interp_case_time(day,day1,annee_ref                &
+     &         ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_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                 &
+     &         ,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)
+
+! vertical interpolation using TOGA interpolation routine:
+!      write(*,*)'avant interp vert', t_prof
+      CALL interp_case_vertical(play,nlev_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           &
+     &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_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,mxcalc)
+!       write(*,*) 'Profil initial forcing case interpole',t_mod
+
+! initial and boundary conditions :
+!      tsurf = ts_prof_cas
+      ts_cur = ts_prof_cas 
+      psurf=plev_prof_cas(1)
+      write(*,*) 'SST initiale: ',tsurf
+      do l = 1, llm
+       temp(l) = t_mod_cas(l)
+       q(l,1) = q_mod_cas(l)
+       q(l,2) = 0.0
+       u(l) = u_mod_cas(l)
+       v(l) = v_mod_cas(l)
+       omega(l) = w_mod_cas(l)
+       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
+
+       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
+!on applique le forcage total au premier pas de temps
+!attention: signe different de toga
+       d_th_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l))
+       d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l))
+       d_q_adv(l,2) = 0.0
+       d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l))
+       d_u_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l))
+      enddo     
+       
+      endif !forcing_case
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/1Dconv.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/1Dconv.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/1Dconv.h	(revision 2298)
@@ -0,0 +1,872 @@
+        subroutine get_uvd(itap,dtime,file_forctl,file_fordat,                  &
+     &       ht,hq,hw,hu,hv,hthturb,hqturb,                                     &
+     &       Ts,imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)                                 
+!
+        implicit none
+ 
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! cette routine permet d obtenir u_convg,v_convg,ht,hq et ainsi de
+! pouvoir calculer la convergence et le cisaillement dans la physiq
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+#include "YOMCST.h"
+
+      INTEGER klev
+      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
+      INTEGER JM(100) !pression en Pa au milieu de chaque couche GCM
+      REAL coef1(100) !coefficient d interpolation
+      REAL coef2(100) !coefficient d interpolation
+
+      INTEGER nblvlm !nombre de niveau de pression du mesoNH
+      REAL playm(100)  !pression en Pa au milieu de chaque couche Meso-NH
+      REAL hplaym(100) !pression en hPa milieux des couches Meso-NH
+
+      integer i,j,k,ll,in
+
+      CHARACTER*80 file_forctl,file_fordat
+
+      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
+      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
+
+!======================================================================
+! methode: on va chercher les donnees du mesoNH de meteo france, on y
+!          a acces a tout pas detemps grace a la routine rdgrads qui
+!          est une boucle lisant dans ces fichiers.
+!          Puis on interpole ces donnes sur les 11 niveaux du gcm et
+!          et sur les pas de temps de ce meme gcm
+!----------------------------------------------------------------------
+! input:
+!       pasmax     :nombre de pas de temps maximum du mesoNH
+!       dt         :pas de temps du meso_NH (en secondes)
+!----------------------------------------------------------------------
+      integer pasmax,dt
+      save pasmax,dt
+!----------------------------------------------------------------------
+! arguments:
+!           itap   :compteur de la physique(le nombre de ces pas est
+!                   fixe dans la subroutine calcul_ini_gcm de interpo
+!                   -lation
+!           dtime  :pas detemps du gcm (en secondes)
+!           ht     :convergence horizontale de temperature(K/s)
+!           hq     :    "         "       d humidite (kg/kg/s)
+!           hw     :vitesse verticale moyenne (m/s**2)
+!           hu     :convergence horizontale d impulsion le long de x
+!                  (kg/(m^2 s^2)
+!           hv     : idem le long de y.
+!           Ts     : Temperature de surface (K)
+!           imp_fcg: var. logical .eq. T si forcage en impulsion
+!           ts_fcg: var. logical .eq. T si forcage en Ts present dans fichier
+!           Tp_fcg: var. logical .eq. T si forcage donne en Temp potentielle
+!           Turb_fcg: var. logical .eq. T si forcage turbulent present dans fichier
+!----------------------------------------------------------------------
+        integer itap
+        real dtime
+        real ht(100)
+        real hq(100)
+        real hu(100)
+        real hv(100)
+        real hw(100)
+        real hthturb(100)
+        real hqturb(100)
+        real Ts, Ts_subr
+        logical imp_fcg
+        logical ts_fcg
+        logical Tp_fcg
+        logical Turb_fcg
+!----------------------------------------------------------------------
+! Variables internes de get_uvd (note : l interpolation temporelle
+! est faite entre les pas de temps before et after, sur les variables
+! definies sur la grille du SCM; on atteint exactement les valeurs Meso
+! aux milieux des pas de temps Meso)
+!     time0     :date initiale en secondes
+!     time      :temps associe a chaque pas du SCM
+!     pas       :numero du pas du meso_NH (on lit en pas : le premier pas
+!                 des donnees est duplique)
+!     pasprev   :numero du pas de lecture precedent
+!     htaft     :advection horizontale de temp. au pas de temps after
+!     hqaft     :    "         "      d humidite        "
+!     hwaft     :vitesse verticalle moyenne  au pas de temps after
+!     huaft,hvaft :advection horizontale d impulsion au pas de temps after
+!     tsaft     : surface temperature 'after time step'
+!     htbef     :idem htaft, mais pour le pas de temps before
+!     hqbef     :voir hqaft
+!     hwbef     :voir hwaft
+!     hubef,hvbef : idem huaft,hvaft, mais pour before
+!     tsbef     : surface temperature 'before time step'
+!----------------------------------------------------------------------
+        integer time0,pas,pasprev
+        save time0,pas,pasprev
+        real time
+        real htaft(100),hqaft(100),hwaft(100),huaft(100),hvaft(100)
+        real hthturbaft(100),hqturbaft(100)
+        real Tsaft
+        save htaft,hqaft,hwaft,huaft,hvaft,hthturbaft,hqturbaft
+        real htbef(100),hqbef(100),hwbef(100),hubef(100),hvbef(100)
+        real hthturbbef(100),hqturbbef(100)
+        real Tsbef
+        save htbef,hqbef,hwbef,hubef,hvbef,hthturbbef,hqturbbef
+!
+        real timeaft,timebef
+        save timeaft,timebef
+        integer temps
+        character*4 string
+!----------------------------------------------------------------------
+! variables arguments de la subroutine rdgrads
+!---------------------------------------------------------------------
+        integer icompt,icomp1 !compteurs de rdgrads
+        real z(100)         ! altitude (grille Meso)
+        real ht_mes(100)    !convergence horizontale de temperature
+                            !-(grille Meso)
+        real hq_mes(100)    !convergence horizontale d humidite
+                            !(grille Meso)
+        real hw_mes(100)    !vitesse verticale moyenne
+                            !(grille Meso)
+        real hu_mes(100),hv_mes(100)    !convergence horizontale d impulsion
+                                        !(grille Meso)
+        real hthturb_mes(100) !tendance horizontale de T_pot, due aux
+                              !flux turbulents
+        real hqturb_mes(100) !tendance horizontale d humidite, due aux
+                              !flux turbulents
+!
+!---------------------------------------------------------------------
+! variable argument de la subroutine copie
+!---------------------------------------------------------------------
+! SB        real pplay(100)    !pression en milieu de couche du gcm
+! SB                            !argument de la physique
+!---------------------------------------------------------------------
+! variables destinees a la lecture du pas de temps du fichier de donnees
+!---------------------------------------------------------------------
+       character*80 aaa,atemps,spaces,apasmax
+       integer nch,imn,ipa
+!---------------------------------------------------------------------
+!  procedures appelees
+        external rdgrads    !lire en iterant dans forcing.dat
+!---------------------------------------------------------------------
+               print*,'le pas itap est:',itap
+!*** on determine le pas du meso_NH correspondant au nouvel itap ***
+!*** pour aller chercher les champs dans rdgrads                 ***
+!
+        time=time0+itap*dtime
+!c        temps=int(time/dt+1)
+!c        pas=min(temps,pasmax)
+        temps = 1 + int((dt + 2*time)/(2*dt))
+        pas=min(temps,pasmax-1)
+             print*,'le pas Meso est:',pas
+!
+!
+!===================================================================
+!
+!*** on remplit les champs before avec les champs after du pas   ***
+!*** precedent en format gcm                                     ***
+        if(pas.gt.pasprev)then
+          do i=1,klev
+             htbef(i)=htaft(i)
+             hqbef(i)=hqaft(i)
+             hwbef(i)=hwaft(i)
+             hubef(i)=huaft(i)
+             hvbef(i)=hvaft(i)
+             hThTurbbef(i)=hThTurbaft(i)
+             hqTurbbef(i)=hqTurbaft(i)
+          enddo
+          tsbef = tsaft
+          timebef=pasprev*dt
+          timeaft=timebef+dt
+          icomp1 = nblvlm*4
+          IF (ts_fcg) icomp1 = icomp1 + 1
+          IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
+          IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
+          icompt = icomp1*pas
+         print *, 'imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt'
+         print *, imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt
+                       print*,'le pas pas est:',pas
+!*** on va chercher les nouveaux champs after dans toga.dat     ***
+!*** champs en format meso_NH                                   ***
+          open(99,FILE=file_fordat,FORM='UNFORMATTED',                        &
+     &             ACCESS='DIRECT',RECL=8)
+          call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes                &
+     &                  ,hu_mes,hv_mes,hthturb_mes,hqturb_mes                 &
+     &                  ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
+!
+
+               if(Tp_fcg) then
+!     (le forcage est donne en temperature potentielle)
+         do i = 1,nblvlm
+           ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
+         enddo
+               endif ! Tp_fcg
+        if(Turb_fcg) then
+         do i = 1,nblvlm
+           hThTurb_mes(i) = hThTurb_mes(i)*(hplaym(i)/1000.)**rkappa
+         enddo
+        endif  ! Turb_fcg
+!
+               print*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
+               print*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
+               print*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
+                  if(imp_fcg) then
+               print*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
+               print*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
+                  endif
+                  if(Turb_fcg) then
+               print*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
+               print*,'hqTurb_mes ',(hqTurb_mes(i),i=1,nblvlm)
+                  endif
+          IF (ts_fcg) print*,'ts_subr', ts_subr
+!*** on interpole les champs meso_NH sur les niveaux de pression***
+!*** gcm . on obtient le nouveau champ after                    ***
+            do k=1,klev
+             if (JM(k) .eq. 0) then
+         htaft(k)=              ht_mes(jm(k)+1)
+         hqaft(k)=              hq_mes(jm(k)+1)
+         hwaft(k)=              hw_mes(jm(k)+1)
+               if(imp_fcg) then
+           huaft(k)=              hu_mes(jm(k)+1)
+           hvaft(k)=              hv_mes(jm(k)+1)
+               endif ! imp_fcg
+               if(Turb_fcg) then
+           hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
+           hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
+               endif ! Turb_fcg
+             else ! JM(k) .eq. 0
+           htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
+           hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
+           hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
+               if(imp_fcg) then
+           huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
+           hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
+               endif ! imp_fcg
+               if(Turb_fcg) then
+           hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                            &
+     &               +coef2(k)*hThTurb_mes(jm(k)+1)
+           hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                             &
+     &               +coef2(k)*hqTurb_mes(jm(k)+1)
+               endif ! Turb_fcg
+             endif ! JM(k) .eq. 0
+            enddo
+            tsaft = ts_subr
+            pasprev=pas
+         else ! pas.gt.pasprev
+            print*,'timebef est:',timebef
+         endif ! pas.gt.pasprev    fin du bloc relatif au passage au pas
+                                  !de temps (meso) suivant
+!*** si on atteint le pas max des donnees experimentales ,on     ***
+!*** on conserve les derniers champs calcules                    ***
+      if(temps.ge.pasmax)then
+          do ll=1,klev
+               ht(ll)=htaft(ll)
+               hq(ll)=hqaft(ll)
+               hw(ll)=hwaft(ll)
+               hu(ll)=huaft(ll)
+               hv(ll)=hvaft(ll)
+               hThTurb(ll)=hThTurbaft(ll)
+               hqTurb(ll)=hqTurbaft(ll)
+          enddo
+          ts_subr = tsaft
+      else ! temps.ge.pasmax
+!*** on interpole sur les pas de temps de 10mn du gcm a partir   ***
+!** des pas de temps de 1h du meso_NH                            ***
+         do j=1,klev
+         ht(j)=((timeaft-time)*htbef(j)+(time-timebef)*htaft(j))/dt
+         hq(j)=((timeaft-time)*hqbef(j)+(time-timebef)*hqaft(j))/dt
+         hw(j)=((timeaft-time)*hwbef(j)+(time-timebef)*hwaft(j))/dt
+             if(imp_fcg) then
+         hu(j)=((timeaft-time)*hubef(j)+(time-timebef)*huaft(j))/dt
+         hv(j)=((timeaft-time)*hvbef(j)+(time-timebef)*hvaft(j))/dt
+             endif ! imp_fcg
+             if(Turb_fcg) then
+         hThTurb(j)=((timeaft-time)*hThTurbbef(j)                           &
+     &           +(time-timebef)*hThTurbaft(j))/dt
+         hqTurb(j)= ((timeaft-time)*hqTurbbef(j)                            &
+     &           +(time-timebef)*hqTurbaft(j))/dt
+             endif ! Turb_fcg
+         enddo
+         ts_subr = ((timeaft-time)*tsbef + (time-timebef)*tsaft)/dt
+       endif ! temps.ge.pasmax
+!
+        print *,' time,timebef,timeaft',time,timebef,timeaft
+        print *,' ht,htbef,htaft,hthturb,hthturbbef,hthturbaft'
+        do j= 1,klev
+           print *, j,ht(j),htbef(j),htaft(j),                              &
+     &             hthturb(j),hthturbbef(j),hthturbaft(j)
+        enddo
+        print *,' hq,hqbef,hqaft,hqturb,hqturbbef,hqturbaft'
+        do j= 1,klev
+           print *, j,hq(j),hqbef(j),hqaft(j),                              &
+     &             hqturb(j),hqturbbef(j),hqturbaft(j)
+        enddo
+!
+!-------------------------------------------------------------------
+!
+         IF (Ts_fcg) Ts = Ts_subr
+         return
+!
+!-----------------------------------------------------------------------
+! on sort les champs de "convergence" pour l instant initial 'in'
+! ceci se passe au pas temps itap=0 de la physique
+!-----------------------------------------------------------------------
+        entry get_uvd2(itap,dtime,file_forctl,file_fordat,                  &
+     &           ht,hq,hw,hu,hv,hThTurb,hqTurb,ts,                          &
+     &           imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)
+             print*,'le pas itap est:',itap
+!
+!===================================================================
+!
+       write(*,'(a)') 'OPEN '//file_forctl
+       open(97,FILE=file_forctl,FORM='FORMATTED')
+!
+!------------------
+      do i=1,1000
+      read(97,1000,end=999) string
+ 1000 format (a4)
+      if (string .eq. 'TDEF') go to 50
+      enddo
+ 50   backspace(97)
+!-------------------------------------------------------------------
+!   *** on lit le pas de temps dans le fichier de donnees ***
+!   *** "forcing.ctl" et pasmax                           ***
+!-------------------------------------------------------------------
+      read(97,2000) aaa
+ 2000  format (a80)
+         print*,'aaa est',aaa
+      aaa=spaces(aaa,1)
+         print*,'aaa',aaa
+      call getsch(aaa,' ',' ',5,atemps,nch)
+         print*,'atemps est',atemps
+        atemps=atemps(1:nch-2)
+         print*,'atemps',atemps
+        read(atemps,*) imn
+        dt=imn*60
+         print*,'le pas de temps dt',dt
+      call getsch(aaa,' ',' ',2,apasmax,nch)
+        apasmax=apasmax(1:nch)
+        read(apasmax,*) ipa
+        pasmax=ipa
+         print*,'pasmax est',pasmax
+      CLOSE(97)
+!------------------------------------------------------------------
+! *** on lit le pas de temps initial de la simulation ***
+!------------------------------------------------------------------
+                  in=itap
+!c                  pasprev=in
+!c                  time0=dt*(pasprev-1)
+                  pasprev=in-1
+                  time0=dt*pasprev
+!
+          close(98)
+!
+      write(*,'(a)') 'OPEN '//file_fordat
+      open(99,FILE=file_fordat,FORM='UNFORMATTED',                          &
+     &          ACCESS='DIRECT',RECL=8)
+          icomp1 = nblvlm*4
+          IF (ts_fcg) icomp1 = icomp1 + 1
+          IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
+          IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
+          icompt = icomp1*(in-1)
+          call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes              &
+     &                   ,hu_mes,hv_mes,hthturb_mes,hqturb_mes              &
+     &                   ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
+          print *, 'get_uvd : rdgrads ->'
+          print *, tp_fcg
+!
+! following commented out because we have temperature already in ARM case
+!   (otherwise this is the potential temperature )
+!------------------------------------------------------------------------
+               if(Tp_fcg) then
+          do i = 1,nblvlm
+            ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
+          enddo
+               endif ! Tp_fcg
+           print*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
+           print*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
+           print*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
+              if(imp_fcg) then
+           print*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
+           print*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
+           print*,'t',ts_subr
+              endif ! imp_fcg
+              if(Turb_fcg) then
+                 print*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
+                 print*,'hqTurb ',     (hqTurb_mes(i),i=1,nblvlm)
+              endif ! Turb_fcg
+!----------------------------------------------------------------------
+! on a obtenu des champs initiaux sur les niveaux du meso_NH
+! on interpole sur les niveaux du gcm(niveau pression bien sur!)
+!-----------------------------------------------------------------------
+            do k=1,klev
+             if (JM(k) .eq. 0) then
+!FKC bug? ne faut il pas convertir tsol en tendance ????
+!RT bug taken care of by removing the stuff
+           htaft(k)=              ht_mes(jm(k)+1)
+           hqaft(k)=              hq_mes(jm(k)+1)
+           hwaft(k)=              hw_mes(jm(k)+1)
+               if(imp_fcg) then
+           huaft(k)=              hu_mes(jm(k)+1)
+           hvaft(k)=              hv_mes(jm(k)+1)
+               endif ! imp_fcg
+               if(Turb_fcg) then
+           hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
+           hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
+               endif ! Turb_fcg
+             else ! JM(k) .eq. 0
+           htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
+           hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
+           hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
+               if(imp_fcg) then
+           huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
+           hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
+               endif ! imp_fcg
+               if(Turb_fcg) then
+           hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                        &
+     &                  +coef2(k)*hThTurb_mes(jm(k)+1)
+           hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                         &
+     &                  +coef2(k)*hqTurb_mes(jm(k)+1)
+               endif ! Turb_fcg
+             endif ! JM(k) .eq. 0
+            enddo
+            tsaft = ts_subr
+! valeurs initiales des champs de convergence
+          do k=1,klev
+             ht(k)=htaft(k)
+             hq(k)=hqaft(k)
+             hw(k)=hwaft(k)
+                if(imp_fcg) then
+             hu(k)=huaft(k)
+             hv(k)=hvaft(k)
+                endif ! imp_fcg
+                if(Turb_fcg) then
+             hThTurb(k)=hThTurbaft(k)
+             hqTurb(k) =hqTurbaft(k)
+                endif ! Turb_fcg
+          enddo
+          ts_subr = tsaft
+          close(99)
+          close(98)
+!
+!-------------------------------------------------------------------
+!
+!
+ 100      IF (Ts_fcg) Ts = Ts_subr
+        return
+!
+999     continue
+        stop 'erreur lecture, file forcing.ctl'
+        end
+
+      SUBROUTINE advect_tvl(dtime,zt,zq,vu_f,vv_f,t_f,q_f                   &
+     &                     ,d_t_adv,d_q_adv)
+      use dimphy
+      implicit none
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+
+      integer k
+      real dtime, fact, du, dv, cx, cy, alx, aly
+      real zt(klev), zq(klev,3)
+      real vu_f(klev), vv_f(klev), t_f(klev), q_f(klev,3)
+
+      real d_t_adv(klev), d_q_adv(klev,3)
+
+! Velocity of moving cell
+      data cx,cy /12., -2./
+
+! Dimensions of moving cell
+      data alx,aly /100000.,150000./
+
+      do k = 1, klev
+            du = abs(vu_f(k)-cx)/alx
+            dv = abs(vv_f(k)-cy)/aly
+            fact = dtime *(du+dv-du*dv*dtime)
+            d_t_adv(k) = fact * (t_f(k)-zt(k))
+            d_q_adv(k,1) = fact * (q_f(k,1)-zq(k,1))
+            d_q_adv(k,2) = fact * (q_f(k,2)-zq(k,2))
+            d_q_adv(k,3) = fact * (q_f(k,3)-zq(k,3))
+      enddo
+
+      return
+      end
+
+      SUBROUTINE copie(klevgcm,playgcm,psolgcm,file_forctl)
+      implicit none
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! cette routine remplit les COMMON com1_phys_gcss et com2_phys_gcss.h
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      INTEGER klev !nombre de niveau de pression du GCM
+      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
+      INTEGER JM(100)
+      REAL coef1(100)   !coefficient d interpolation
+      REAL coef2(100)   !coefficient d interpolation
+
+      INTEGER nblvlm !nombre de niveau de pression du mesoNH
+      REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH
+      REAL hplaym(100)!pression en hecto-Pa des milieux de couche Meso-NH
+
+      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
+      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
+
+      integer k,klevgcm
+      real playgcm(klevgcm) ! pression en milieu de couche du gcm
+      real psolgcm
+      character*80 file_forctl
+
+      klev = klevgcm
+
+!---------------------------------------------------------------------
+! pression au milieu des couches du gcm dans la physiq
+! (SB: remplace le call conv_lipress_gcm(playgcm) )
+!---------------------------------------------------------------------
+
+       do k = 1, klev
+        play(k) = playgcm(k)
+        print*,'la pression gcm est:',play(k)
+       enddo
+
+!----------------------------------------------------------------------
+! lecture du descripteur des donnees Meso-NH (forcing.ctl):
+!  -> nb niveaux du meso.NH (nblvlm) + pressions meso.NH
+! (on remplit le COMMON com2_phys_gcss)
+!----------------------------------------------------------------------
+
+      call mesolupbis(file_forctl)
+
+      print*,'la valeur de nblvlm est:',nblvlm
+
+!----------------------------------------------------------------------
+! etude de la correspondance entre les niveaux meso.NH et GCM;
+! calcul des coefficients d interpolation coef1 et coef2
+! (on remplit le COMMON com1_phys_gcss)
+!----------------------------------------------------------------------
+
+      call corresbis(psolgcm)
+
+!---------------------------------------------------------
+! TEST sur le remplissage de com1_phys_gcss et com2_phys_gcss:
+!---------------------------------------------------------
+ 
+      write(*,*) ' '
+      write(*,*) 'TESTS com1_phys_gcss et com2_phys_gcss dans copie.F'
+      write(*,*) '--------------------------------------'
+      write(*,*) 'GCM: nb niveaux:',klev,' et pression, coeffs:'
+      do k = 1, klev
+      write(*,*) play(k), coef1(k), coef2(k)
+      enddo
+      write(*,*) 'MESO-NH: nb niveaux:',nblvlm,' et pression:'
+      do k = 1, nblvlm
+      write(*,*) playm(k), hplaym(k)
+      enddo
+      write(*,*) ' '
+
+      end
+      SUBROUTINE mesolupbis(file_forctl)
+      implicit none 
+!
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!
+! Lecture descripteur des donnees MESO-NH (forcing.ctl):
+! -------------------------------------------------------
+!
+!     Cette subroutine lit dans le fichier de controle "essai.ctl"
+!     et affiche le nombre de niveaux du Meso-NH ainsi que les valeurs
+!     des pressions en milieu de couche du Meso-NH (en Pa puis en hPa).
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!
+      INTEGER nblvlm !nombre de niveau de pression du mesoNH
+      REAL playm(100)  !pression en Pa milieu de chaque couche Meso-NH
+      REAL hplaym(100) !pression en hPa des milieux de couche Meso-NH
+      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
+
+      INTEGER i,lu,mlz,mlzh
+ 
+      character*80 file_forctl
+
+      character*4 a
+      character*80 aaa,anblvl,spaces
+      integer nch
+
+      lu=9
+      open(lu,file=file_forctl,form='formatted')
+!
+      do i=1,1000
+      read(lu,1000,end=999) a
+      if (a .eq. 'ZDEF') go to 100
+      enddo
+!
+ 100  backspace(lu)
+      print*,'  DESCRIPTION DES 2 MODELES : '
+      print*,' '
+!
+      read(lu,2000) aaa
+ 2000  format (a80)
+       aaa=spaces(aaa,1)
+       call getsch(aaa,' ',' ',2,anblvl,nch)
+         read(anblvl,*) nblvlm
+
+!
+      print*,'nbre de niveaux de pression Meso-NH :',nblvlm
+      print*,' '
+      print*,'pression en Pa de chaque couche du meso-NH :'
+!
+      read(lu,*) (playm(mlz),mlz=1,nblvlm)
+!      Si la pression est en HPa, la multiplier par 100
+      if (playm(1) .lt. 10000.) then
+        do mlz = 1,nblvlm
+         playm(mlz) = playm(mlz)*100.
+        enddo
+      endif
+      print*,(playm(mlz),mlz=1,nblvlm)
+!
+ 1000 format (a4)
+ 1001 format(5x,i2)
+!
+      print*,' '
+      do mlzh=1,nblvlm
+      hplaym(mlzh)=playm(mlzh)/100.
+      enddo
+!
+      print*,'pression en hPa de chaque couche du meso-NH: '
+      print*,(hplaym(mlzh),mlzh=1,nblvlm)
+!
+      close (lu)
+      return
+!
+ 999  stop 'erreur lecture des niveaux pression des donnees'
+      end
+
+      SUBROUTINE rdgrads(itape,icount,nl,z,ht,hq,hw,hu,hv,hthtur,hqtur,     &
+     &  ts_fcg,ts,imp_fcg,Turb_fcg)
+      IMPLICIT none
+      INTEGER itape,icount,icomp, nl
+      real z(nl),ht(nl),hq(nl),hw(nl),hu(nl),hv(nl)
+      real hthtur(nl),hqtur(nl)
+      real ts
+!
+      INTEGER k
+!
+      LOGICAL imp_fcg,ts_fcg,Turb_fcg
+!
+      icomp = icount
+!
+!
+         do k=1,nl
+            icomp=icomp+1
+            read(itape,rec=icomp)z(k)
+            print *,'icomp,k,z(k) ',icomp,k,z(k)
+         enddo
+         do k=1,nl
+            icomp=icomp+1
+            read(itape,rec=icomp)hT(k)
+             print*, hT(k), k
+         enddo
+         do k=1,nl
+            icomp=icomp+1
+            read(itape,rec=icomp)hQ(k)
+         enddo
+!
+             if(turb_fcg) then
+         do k=1,nl
+            icomp=icomp+1
+           read(itape,rec=icomp)hThTur(k)
+         enddo
+         do k=1,nl
+            icomp=icomp+1
+           read(itape,rec=icomp)hqTur(k)
+         enddo
+             endif
+         print *,' apres lecture hthtur, hqtur'
+!
+          if(imp_fcg) then
+
+         do k=1,nl
+            icomp=icomp+1
+           read(itape,rec=icomp)hu(k)
+         enddo
+         do k=1,nl
+            icomp=icomp+1
+            read(itape,rec=icomp)hv(k)
+         enddo
+
+          endif
+!
+         do k=1,nl
+            icomp=icomp+1
+            read(itape,rec=icomp)hw(k)
+         enddo
+!
+              if(ts_fcg) then
+         icomp=icomp+1
+         read(itape,rec=icomp)ts
+              endif
+!
+      print *,' rdgrads ->'
+
+      RETURN
+      END
+
+      SUBROUTINE corresbis(psol)
+      implicit none
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! Cette subroutine calcule et affiche les valeurs des coefficients
+! d interpolation qui serviront dans la formule d interpolation elle-
+! meme.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      INTEGER klev    !nombre de niveau de pression du GCM
+      REAL play(100)  !pression en Pa au milieu de chaque couche GCM
+      INTEGER JM(100)
+      REAL coef1(100) !coefficient d interpolation
+      REAL coef2(100) !coefficient d interpolation
+
+      INTEGER nblvlm !nombre de niveau de pression du mesoNH
+      REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH
+      REAL hplaym(100)!pression en hPa des milieux de couche Meso-NH
+
+      COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
+      COMMON/com2_phys_gcss/playm,hplaym,nblvlm
+
+      REAL psol
+      REAL val
+      INTEGER k, mlz
+
+
+      do k=1,klev
+         val=play(k)
+       if (val .gt. playm(1)) then
+          mlz = 0
+          JM(1) = mlz
+          coef1(1)=(playm(mlz+1)-val)/(playm(mlz+1)-psol)
+          coef2(1)=(val-psol)/(playm(mlz+1)-psol)
+       else if (val .gt. playm(nblvlm)) then
+         do mlz=1,nblvlm
+          if (     val .le. playm(mlz).and. val .gt. playm(mlz+1))then
+           JM(k)=mlz
+           coef1(k)=(playm(mlz+1)-val)/(playm(mlz+1)-playm(mlz))
+           coef2(k)=(val-playm(mlz))/(playm(mlz+1)-playm(mlz))
+          endif
+         enddo
+       else
+         JM(k) = nblvlm-1
+         coef1(k) = 0.
+         coef2(k) = 0.
+       endif
+      enddo
+!
+!c      if (play(klev) .le. playm(nblvlm)) then
+!c         mlz=nblvlm-1
+!c         JM(klev)=mlz
+!c         coef1(klev)=(playm(mlz+1)-val)
+!c     *            /(playm(mlz+1)-playm(mlz))
+!c         coef2(klev)=(val-playm(mlz))
+!c     *            /(playm(mlz+1)-playm(mlz))
+!c      endif
+!
+      print*,' '
+      print*,'         INTERPOLATION  : '
+      print*,' '
+      print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
+      print*,(JM(k),k=1,klev)
+      print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
+      print*,(JM(k),k=1,klev)
+      print*,' '
+      print*,'vals du premier coef d"interpolation pour les 9 niveaux: '
+      print*,(coef1(k),k=1,klev)
+      print*,' '
+      print*,'valeurs du deuxieme coef d"interpolation pour les 9 niveaux:'
+      print*,(coef2(k),k=1,klev)
+!
+      return
+      end
+      SUBROUTINE GETSCH(STR,DEL,TRM,NTH,SST,NCH)
+!***************************************************************
+!*                                                             *
+!*                                                             *
+!* GETSCH                                                      *
+!*                                                             *
+!*                                                             *
+!* modified by :                                               *
+!***************************************************************
+!*   Return in SST the character string found between the NTH-1 and NTH
+!*   occurence of the delimiter 'DEL' but before the terminator 'TRM' in
+!*   the input string 'STR'. If TRM=DEL then STR is considered unlimited.
+!*   NCH=Length of the string returned in SST or =-1 if NTH is <1 or if
+!*   NTH is greater than the number of delimiters in STR.
+      IMPLICIT INTEGER (A-Z)
+      CHARACTER STR*(*),DEL*1,TRM*1,SST*(*)
+      NCH=-1
+      SST=' '
+      IF(NTH.GT.0) THEN
+        IF(TRM.EQ.DEL) THEN
+          LENGTH=LEN(STR)
+        ELSE
+          LENGTH=INDEX(STR,TRM)-1
+          IF(LENGTH.LT.0) LENGTH=LEN(STR)
+        ENDIF
+!*     Find beginning and end of the NTH DEL-limited substring in STR
+        END=-1
+        DO 1,N=1,NTH
+        IF(END.EQ.LENGTH) RETURN
+        BEG=END+2
+        END=BEG+INDEX(STR(BEG:LENGTH),DEL)-2
+        IF(END.EQ.BEG-2) END=LENGTH
+!*        PRINT *,'NTH,LENGTH,N,BEG,END=',NTH,LENGTH,N,BEG,END
+    1   CONTINUE
+        NCH=END-BEG+1
+        IF(NCH.GT.0) SST=STR(BEG:END)
+      ENDIF
+      END
+      CHARACTER*(*) FUNCTION SPACES(STR,NSPACE)
+!
+! CERN PROGLIB# M433    SPACES          .VERSION KERNFOR  4.14  860211
+! ORIG.  6/05/86 M.GOOSSENS/DD
+!
+!-    The function value SPACES returns the character string STR with
+!-    leading blanks removed and each occurence of one or more blanks
+!-    replaced by NSPACE blanks inside the string STR
+!
+      CHARACTER*(*) STR
+!
+      LENSPA = LEN(SPACES)
+      SPACES = ' '
+      IF (NSPACE.LT.0) NSPACE = 0
+      IBLANK = 1
+      ISPACE = 1
+  100 INONBL = INDEXC(STR(IBLANK:),' ')
+      IF (INONBL.EQ.0) THEN
+          SPACES(ISPACE:) = STR(IBLANK:)
+                                                    GO TO 999
+      ENDIF
+      INONBL = INONBL + IBLANK - 1
+      IBLANK = INDEX(STR(INONBL:),' ')
+      IF (IBLANK.EQ.0) THEN
+          SPACES(ISPACE:) = STR(INONBL:)
+                                                    GO TO 999
+      ENDIF
+      IBLANK = IBLANK + INONBL - 1
+      SPACES(ISPACE:) = STR(INONBL:IBLANK-1)
+      ISPACE = ISPACE + IBLANK - INONBL + NSPACE
+      IF (ISPACE.LE.LENSPA)                         GO TO 100
+  999 END
+      FUNCTION INDEXC(STR,SSTR)
+!
+! CERN PROGLIB# M433    INDEXC          .VERSION KERNFOR  4.14  860211
+! ORIG. 26/03/86 M.GOOSSENS/DD
+!
+!-    Find the leftmost position where substring SSTR does not match
+!-    string STR scanning forward
+!
+      CHARACTER*(*) STR,SSTR
+!
+      LENS   = LEN(STR)
+      LENSS  = LEN(SSTR)
+!
+      DO 10 I=1,LENS-LENSS+1
+          IF (STR(I:I+LENSS-1).NE.SSTR) THEN
+              INDEXC = I
+                                         GO TO 999
+          ENDIF
+   10 CONTINUE
+      INDEXC = 0
+!
+  999 END
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/comconst.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/comconst.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/comconst.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comconst.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/comdissnew.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/comdissnew.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/comdissnew.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comdissnew.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comgeom.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom2.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom2.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/comgeom2.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comgeom2.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/comvert.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/comvert.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/comvert.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comvert.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/conf_gcm.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/conf_gcm.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/conf_gcm.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d/conf_gcm.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/control_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/control_mod.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/control_mod.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/control_mod.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/disvert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/disvert.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/disvert.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/disvert.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/ener.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/ener.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/ener.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/ener.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/exner_hyb_m.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/exner_hyb_m.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/exner_hyb_m.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/exner_hyb_m.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/infotrac.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/infotrac.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/infotrac.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/infotrac.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/iniphysiq.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/iniphysiq.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/phylmd/iniphysiq.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/lmdz1d.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/lmdz1d.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/lmdz1d.F90	(revision 2298)
@@ -0,0 +1,1052 @@
+!#ifdef CPP_1D
+!#include "../dyn3d/mod_const_mpi.F90"
+!#include "../dyn3d_common/control_mod.F90"
+!#include "../dyn3d_common/infotrac.F90"
+!#include "../dyn3d_common/disvert.F90"
+
+
+      PROGRAM lmdz1d
+
+      USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar
+      use phys_state_var_mod
+      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_amma_read
+
+      implicit none
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "temps.h"
+!!#include "control.h"
+#include "iniprint.h"
+#include "clesphys.h"
+#include "dimsoil.h"
+!#include "indicesol.h"
+
+#include "comvert.h"
+#include "compar1d.h"
+#include "flux_arp.h"
+#include "tsoilnudge.h"
+#include "fcg_gcssold.h"
+!!!#include "fbforcing.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_GCM2SCM = .false.
+        logical :: forcing_GCSSold = .false.
+        logical :: forcing_sandu   = .false.
+        logical :: forcing_astex   = .false.
+        logical :: forcing_fire    = .false.
+        logical :: forcing_case    = .false.
+        integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
+!                                                            (cf read_tsurf1d.F)
+
+!vertical advection computation
+!       real d_t_z(llm), d_q_z(llm)
+!       real d_t_dyn_z(llm), d_q_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 "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),poub
+
+!---------------------------------------------------------------------
+!  Declarations related to variables
+!---------------------------------------------------------------------
+
+      real :: phi(llm)
+      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
+      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_th_adv(llm),d_t_nudge(llm)
+      real :: d_u_nudge(llm),d_v_nudge(llm)
+      real :: du_adv(llm),dv_adv(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    = 0.0
+      real :: dpsrf 
+
+!---------------------------------------------------------------------
+!  Initializations of boundary conditions 
+!---------------------------------------------------------------------
+      integer, parameter :: yd = 360
+      real :: phy_nat (yd) = 0.0 ! 0=ocean libre,1=land,2=glacier,3=banquise
+      real :: phy_alb (yd)  ! Albedo land only (old value condsurf_jyg=0.3)
+      real :: phy_sst (yd)  ! SST (will not be used; cf read_tsurf1d.F)
+      real :: phy_bil (yd) = 1.0 ! Ne sert que pour les slab_ocean
+      real :: phy_rug (yd) ! Longueur rugosite utilisee sur land only
+      real :: phy_ice (yd) = 0.0 ! Fraction de glace
+      real :: phy_fter(yd) = 0.0 ! Fraction de terre
+      real :: phy_foce(yd) = 0.0 ! Fraction de ocean
+      real :: phy_fsic(yd) = 0.0 ! Fraction de glace
+      real :: phy_flic(yd) = 0.0 ! Fraction de glace
+
+!---------------------------------------------------------------------
+!  Fichiers et d'autres variables
+!---------------------------------------------------------------------
+      integer :: k,l,i,it=1,mxcalc
+      integer jcode
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+      REAL dudyn(iim+1,jjmp1,llm)
+      INTEGER read_climoz 
+!Al1
+      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
+      data ecrit_slab_oc/-1/
+
+!=====================================================================
+! INITIALIZATIONS 
+!=====================================================================
+! 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 = 10 ==> forcing_case = .true.
+!             initial profiles and large scale forcings in cas.nc
+!             LS convergence, omega and SST imposed from CINDY-DYNAMO files 
+!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 .eq.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.10) THEN
+       forcing_case = .true.
+      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. )
+!-----------------------------------------------------------------------
+!   Choix du calendrier
+!   -------------------
+
+!      calend = 'earth_365d'
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360d')
+        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
+        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
+
+! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
+      IF(forcing_type .EQ. 61) 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.
+      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 + 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.10) THEN
+! Convert the initial date to Julian day
+      print*,'time cindy',year_ini_cas,mth_ini_cas,day_ini_cas
+      call ymds2ju                                                         &
+     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas &
+     & ,day_ju_ini_cas)
+      print*,'time cindy 2',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
+
+      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,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/))
+      call suphel
+      call infotrac_init 
+
+      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)) 
+
+!
+!   No ozone climatology need be read in this pre-initialization
+!          (phys_state_var_init is called again in physiq)
+      read_climoz = 0
+!
+      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.)
+      rlat=xlat
+      rlon=xlon
+      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'
+      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))
+!cc      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"
+
+      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
+      ts_cur = 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(:)=rlat(:)*rpi/180.
+      rlon_rad(:)=rlon(:)*rpi/180.
+
+      call iniphysiq(iim,jjm,llm,rday,day_ini,timestep,                        &
+     &     rlat_rad,rlon_rad,airefi,zcufi,zcvfi,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,:)=0.        ! couverture 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,:)=rugos     ! 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.
+        else
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=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
+        nsw=6 ! on met le nb de bandes SW=6, pour initialiser
+              ! 6 albedo, mais on peut quand meme tourner avec
+              ! moins. Seules les 2 ou 4 premiers seront lus
+        falb_dir=albedo
+        falb_dif=albedo
+        rugoro=rugos 
+        t_ancien(1,:)=temp(:)
+        q_ancien(1,:)=q(:,1)
+        pbl_tke(:,:,:)=1.e-8
+        wake_delta_pbl_tke(:,:,:)=0.
+
+        rain_fall=0.
+        snow_fall=0.
+        solsw=0.
+        sollw=0.
+        radsol=0.
+        rnebcon=0.
+        ratqs=0.
+        clwcon=0.
+        zmea=0.
+        zstd=0.
+        zsig=0.
+        zgam=0.
+        zval=0. 
+        zthe=0. 
+        sig1=0.
+        w01=0.
+        u_ancien(1,:)=u(:)
+        v_ancien(1,:)=v(:)
+ 
+!------------------------------------------------------------------------
+! 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,sollw,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,wake_cstar,wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
+!------------------------------------------------------------------------
+!Al1 =============== restart option ==========================
+        if (.not.restart) then
+          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,yd
+        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
+!
+!=====================================================================
+! START OF THE TEMPORAL LOOP :
+!=====================================================================
+           
+      do while(it.le.nint(fnday*day_step))
+
+       if (prt_level.ge.1) then
+         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
+     &                                it,day,time,nint(fnday*day_step)
+         print*,'PAS DE TEMPS ',timestep
+       endif
+!Al1 demande de restartphy.nc
+       if (it.eq.nint(fnday*day_step)) lastcall=.True.
+
+!---------------------------------------------------------------------
+! Interpolation of forcings in time and onto model levels
+!---------------------------------------------------------------------
+
+#include "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
+         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,                                     &
+     &              day,time,timestep,                                      &
+     &              plev,play,phi,phis,presnivs,                            &
+     &              u,v,temp,q,omega2,                                      &
+     &              du_phys,dv_phys,dt_phys,dq,dpsrf,                        &
+     &              dudyn)
+        firstcall=.false.
+
+!---------------------------------------------------------------------
+! Listing output for debug prt_level>=1
+!---------------------------------------------------------------------
+        if (prt_level>=1) 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_th_adv=0.0
+         d_q_adv=0.0
+       endif
+
+       if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
+     &    .or.forcing_amma) then
+         fcoriolis=0.0 ; ug=0. ; vg=0.
+       endif
+         if(forcing_rico) then
+          dt_cooling=0.
+        endif
+
+      print*, 'fcoriolis ', fcoriolis, xlat
+
+        du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
+       dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
+
+!!!!!!!!!!!!!!!!!!!!!!!!
+! Geostrophic wind
+!!!!!!!!!!!!!!!!!!!!!!!!
+       sfdt = sin(0.5*fcoriolis*timestep)
+       cfdt = cos(0.5*fcoriolis*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
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!         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
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 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.1) then
+          print *,                                                          &
+     &    'physiq-> temp(1),dt_phys(1),d_th_adv(1),dt_cooling(1) ',         &
+     &              temp(1),dt_phys(1),d_th_adv(1),dt_cooling(1)
+           print*,du_phys
+           print*, v
+           print*, vg
+        endif
+
+        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
+     &              dt_phys(1:mxcalc)                                       &
+     &             +d_th_adv(1:mxcalc)                                      &
+     &             +d_t_nudge(1:mxcalc)                                      &
+     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
+
+      endif  ! forcing_sandu or forcing_astex
+
+        teta=temp*(pzero/play)**rkappa
+!
+!---------------------------------------------------------------------
+!   Nudge soil temperature if requested
+!---------------------------------------------------------------------
+
+      IF (nudge_tsoil) 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)
+
+!---------------------------------------------------------------------
+!   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
+
+#include "1DUTILS.h"
+#include "1Dconv.h"
+
+!#endif
+
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/logic.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/logic.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/logic.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d/logic.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_const_mpi.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_const_mpi.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_const_mpi.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d/mod_const_mpi.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_grid_phy_lmdz.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_grid_phy_lmdz.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_grid_phy_lmdz.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_data.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_data.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_mpi_data.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_transfert.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_mpi_transfert.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_mpi_transfert.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_data.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_data.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_omp_data.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_transfert.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_omp_transfert.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_omp_transfert.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_para.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_para.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_para.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_transfert_para.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_phys_lmdz_transfert_para.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dynlonlat_phylonlat/mod_phys_lmdz_transfert_para.F90
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/paramet.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/paramet.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/paramet.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d/paramet.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/q_sat.F
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/q_sat.F	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/q_sat.F	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/q_sat.F
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/serre.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/serre.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/serre.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/serre.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/temps.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/temps.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/temps.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d/temps.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/tracstoke.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/tracstoke.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/tracstoke.h	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/tracstoke.h
Index: LMDZ5/branches/testing/libf/phylmd/dyn1d/write_field.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/dyn1d/write_field.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/dyn1d/write_field.F90	(revision 2298)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/write_field.F90
Index: LMDZ5/branches/testing/libf/phylmd/etat0_netcdf.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/etat0_netcdf.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/etat0_netcdf.F90	(revision 2298)
@@ -5,4 +5,5 @@
 !
 SUBROUTINE etat0_netcdf(ib, masque, phis, letat0)
+#ifndef CPP_1D
 !
 !-------------------------------------------------------------------------------
@@ -53,5 +54,5 @@
 #include "dimsoil.h"
 #include "temps.h"
-  REAL,    DIMENSION(klon)                 :: tsol, qsol
+  REAL,    DIMENSION(klon)                 :: tsol
   REAL,    DIMENSION(klon)                 :: sn, rugmer, run_off_lic_0
   REAL,    DIMENSION(iip1,jjp1)            :: orog, rugo, psol
@@ -60,6 +61,5 @@
   REAL,    DIMENSION(iip1,jjm ,llm)        :: vvent
   REAL,    DIMENSION(:,:,:,:), ALLOCATABLE :: q3d
-  REAL,    DIMENSION(klon,nbsrf)           :: qsolsrf, snsrf, evap
-  REAL,    DIMENSION(klon,nbsrf)           :: frugs, agesno
+  REAL,    DIMENSION(klon,nbsrf)           :: qsolsrf, snsrf
   REAL,    DIMENSION(klon,nsoilmx,nbsrf)   :: tsoil
 
@@ -479,12 +479,9 @@
   DO i=1,nbsrf; ftsol(:,i) = tsol; END DO
   DO i=1,nbsrf; snsrf(:,i) = sn;   END DO
-  falb1(:,is_ter) = 0.08; falb1(:,is_lic) = 0.6
-  falb1(:,is_oce) = 0.5;  falb1(:,is_sic) = 0.6
-  falb2 = falb1
 !albedo SB >>>
   falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
   falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
 !albedo SB <<<
-  evap(:,:) = 0.
+  fevap(:,:) = 0.
   DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO
   DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO
@@ -494,8 +491,11 @@
   q_ancien = 0.
   agesno = 0.
-  frugs(:,is_oce) = rugmer(:)
-  frugs(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-  frugs(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-  frugs(:,is_sic) = 0.001
+
+  z0m(:,is_oce) = rugmer(:)
+  z0m(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+  z0m(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+  z0m(:,is_sic) = 0.001
+  z0h(:,:)=z0m(:,:)
+
   fder = 0.0
   clwcon = 0.0
@@ -525,5 +525,5 @@
 
   CALL fonte_neige_init(run_off_lic_0)
-  CALL pbl_surface_init( qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, tsoil )
+  CALL pbl_surface_init( fder, snsrf, qsolsrf, tsoil )
   CALL phyredem( "startphy.nc" )
 
@@ -535,5 +535,6 @@
 !#endif of #ifdef CPP_EARTH
   RETURN
-
+#endif
+!#endif of ifndef CPP_1D
 END SUBROUTINE etat0_netcdf
 !
Index: LMDZ5/branches/testing/libf/phylmd/ini_histrac.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/ini_histrac.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/ini_histrac.h	(revision 2298)
@@ -30,5 +30,6 @@
 !----------------
      DO it = 1,nbtr
-        iiq = niadv(it+2)
+!!        iiq = niadv(it+2)                                                         ! jyg
+        iiq = niadv(it+nqo)                                                         ! jyg
 
 ! CONCENTRATIONS
Index: LMDZ5/branches/testing/libf/phylmd/init_phys_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/init_phys_lmdz.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/init_phys_lmdz.F90	(revision 2298)
@@ -3,6 +3,6 @@
 !
 SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz
+  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, ONLY : type_trac
Index: LMDZ5/branches/testing/libf/phylmd/iotd.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/iotd.h	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/iotd.h	(revision 2298)
@@ -0,0 +1,16 @@
+!=======================================================================
+!
+!   Auteur:  F. Hourdin
+!   -------
+!
+!   Objet:
+!   ------
+!   Light interface for netcdf outputs. can be used outside LMDZ
+!
+!=======================================================================
+
+      integer imax,jmax,lmax,nid
+      INTEGER dim_coord(4)
+      real iotd_ts
+
+      common/ecritd_c/imax,jmax,lmax,nid,dim_coord,iotd_ts
Index: LMDZ5/branches/testing/libf/phylmd/iotd_ecrit.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/iotd_ecrit.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/iotd_ecrit.F90	(revision 2298)
@@ -0,0 +1,180 @@
+      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
+!
+!=================================================================
+ 
+      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
+      
+
+!***************************************************************
+! 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=ntime
+!          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= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+
+!          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= NF_PUT_VARA_REAL(nid,varid,corner,edges,zx)
+
+      if (ierr.ne.NF_NOERR) then
+           write(*,*) "***** PUT_VAR problem in writediagfi"
+           write(*,*) "***** with ",nom
+           write(*,*) 'ierr=', ierr
+      endif 
+
+
+      end
Index: LMDZ5/branches/testing/libf/phylmd/iotd_fin.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/iotd_fin.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/iotd_fin.F90	(revision 2298)
@@ -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: LMDZ5/branches/testing/libf/phylmd/iotd_ini.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/iotd_ini.F90	(revision 2298)
+++ LMDZ5/branches/testing/libf/phylmd/iotd_ini.F90	(revision 2298)
@@ -0,0 +1,116 @@
+      SUBROUTINE iotd_ini(fichnom,iim,jjm,llm,prlonv,prlatu,pcoordv)
+      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 prlonv(iim),prlatu(jjm),pcoordv(llm),timestep
+      INTEGER id_FOCE
+
+      integer corner(4),edges(4),ndim
+      real  px(1000)
+      character (len=10) :: nom
+
+!   Local:
+!   ------
+      INTEGER ierr
+
+      integer :: nvarid
+      integer, dimension(2) :: id  
+      integer :: varid
+
+      character*10 fichnom
+      real*4 rlonv(iim),rlatu(jjm),coordv(llm)
+
+      real pi
+
+      print*,'INIIO prlonv ',prlonv
+      imax=iim
+      jmax=jjm
+      lmax=llm
+
+      rlonv=prlonv
+      rlatu=prlatu
+      coordv=pcoordv
+
+!-----------------------------------------------------------------------
+
+
+      pi=2.*asin(1.)
+
+! Define dimensions
+    
+         ! Create the NetCDF file
+         ierr=NF_CREATE(fichnom, NF_CLOBBER, nid)
+         ! Define the 'Time' dimension
+         ierr=nf_def_dim(nid,"Time",NF_UNLIMITED,dim_coord(4))
+         ! Define the 'Time' variable
+         ierr=NF_DEF_VAR(nid, "Time", NF_FLOAT, 1, dim_coord(4),varid)
+!        ! Add a long_name attribute
+!        ierr=NF_PUT_ATT_TEXT(nid, varid, "long_name",4,"Time")
+!        ! Add a units attribute
+         ierr=NF_PUT_ATT_TEXT(nid, varid,'units',29,"days since 0000-00-0 00:00:00")
+         ! Switch out of NetCDF Define mode
+
+      ierr=NF_DEF_DIM(nid, "longitude", iim, dim_coord(1))
+      ierr=NF_DEF_DIM(nid, "latitude", jjm, dim_coord(2))
+      ierr=NF_DEF_DIM(nid, "altitude", llm, dim_coord(3))
+
+
+      ierr=NF_ENDDEF(nid)
+!
+!  Contol parameters for this run
+! --------------------------
+
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, dim_coord(1),nvarid)
+!     ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name", 14,
+!    .      "East longitude")
+!     ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr=NF_ENDDEF(nid)
+      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlonv)
+       print*,ierr
+
+! --------------------------
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid, "latitude", NF_FLOAT, 1, dim_coord(2),nvarid)
+!     ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+!     ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name", 14,"North latitude")
+      ierr=NF_ENDDEF(nid)
+      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlatu)
+!
+! --------------------------
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid, "altitude", NF_FLOAT, 1,dim_coord(3),nvarid)
+      ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"pseudo-alt")
+!     ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',2,"km")
+      if ( pcoordv(2)>pcoordv(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)
+!
+      END
Index: LMDZ5/branches/testing/libf/phylmd/limit_netcdf.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/limit_netcdf.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/limit_netcdf.F90	(revision 2298)
@@ -4,4 +4,5 @@
 !
 SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque)
+#ifndef CPP_1D
 !
 !-------------------------------------------------------------------------------
@@ -662,3 +663,5 @@
 ! of #ifdef CPP_EARTH
 
+#endif
+! of #ifndef CPP_1D
 END SUBROUTINE limit_netcdf
Index: LMDZ5/branches/testing/libf/phylmd/lmdz1d.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/lmdz1d.F90	(revision 2274)
+++ 	(revision )
@@ -1,1055 +1,0 @@
-#ifdef CPP_1D
-#include "../dyn3d/mod_const_mpi.F90"
-#include "../dyn3d_common/control_mod.F90"
-#include "../dyn3d_common/infotrac.F90"
-#include "../dyn3d_common/disvert.F90"
-
-
-      PROGRAM lmdz1d
-
-      USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar
-      use phys_state_var_mod
-      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_amma_read
-
-      implicit none
-#include "dimensions.h"
-#include "YOMCST.h"
-#include "temps.h"
-!!#include "control.h"
-#include "iniprint.h"
-#include "clesphys.h"
-#include "dimsoil.h"
-!#include "indicesol.h"
-
-#include "comvert.h"
-#include "compar1d.h"
-#include "flux_arp.h"
-#include "tsoilnudge.h"
-#include "fcg_gcssold.h"
-!!!#include "fbforcing.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_GCM2SCM = .false.
-        logical :: forcing_GCSSold = .false.
-        logical :: forcing_sandu   = .false.
-        logical :: forcing_astex   = .false.
-        logical :: forcing_fire    = .false.
-        logical :: forcing_case    = .false.
-        integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
-!                                                            (cf read_tsurf1d.F)
-
-!vertical advection computation
-!       real d_t_z(llm), d_q_z(llm)
-!       real d_t_dyn_z(llm), d_q_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 "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),poub
-
-!---------------------------------------------------------------------
-!  Declarations related to variables
-!---------------------------------------------------------------------
-
-      real :: phi(llm)
-      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
-      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_th_adv(llm),d_t_nudge(llm)
-      real :: d_u_nudge(llm),d_v_nudge(llm)
-      real :: du_adv(llm),dv_adv(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 :: evap(1,nbsrf),frugs(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    = 0.0
-      real :: dpsrf 
-
-!---------------------------------------------------------------------
-!  Initializations of boundary conditions 
-!---------------------------------------------------------------------
-      integer, parameter :: yd = 360
-      real :: phy_nat (yd) = 0.0 ! 0=ocean libre,1=land,2=glacier,3=banquise
-      real :: phy_alb (yd)  ! Albedo land only (old value condsurf_jyg=0.3)
-      real :: phy_sst (yd)  ! SST (will not be used; cf read_tsurf1d.F)
-      real :: phy_bil (yd) = 1.0 ! Ne sert que pour les slab_ocean
-      real :: phy_rug (yd) ! Longueur rugosite utilisee sur land only
-      real :: phy_ice (yd) = 0.0 ! Fraction de glace
-      real :: phy_fter(yd) = 0.0 ! Fraction de terre
-      real :: phy_foce(yd) = 0.0 ! Fraction de ocean
-      real :: phy_fsic(yd) = 0.0 ! Fraction de glace
-      real :: phy_flic(yd) = 0.0 ! Fraction de glace
-
-!---------------------------------------------------------------------
-!  Fichiers et d'autres variables
-!---------------------------------------------------------------------
-      integer :: k,l,i,it=1,mxcalc
-      integer jcode
-      integer jjmp1
-      parameter (jjmp1=jjm+1-1/jjm)
-      REAL dudyn(iim+1,jjmp1,llm)
-      INTEGER read_climoz 
-!Al1
-      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
-      data ecrit_slab_oc/-1/
-
-!=====================================================================
-! INITIALIZATIONS 
-!=====================================================================
-! 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 = 10 ==> forcing_case = .true.
-!             initial profiles and large scale forcings in cas.nc
-!             LS convergence, omega and SST imposed from CINDY-DYNAMO files 
-!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 .eq.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.10) THEN
-       forcing_case = .true.
-      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. )
-!-----------------------------------------------------------------------
-!   Choix du calendrier
-!   -------------------
-
-!      calend = 'earth_365d'
-      if (calend == 'earth_360d') then
-        call ioconf_calendar('360d')
-        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
-        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
-
-! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
-      IF(forcing_type .EQ. 61) 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.
-      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 + 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.10) THEN
-! Convert the initial date to Julian day
-      print*,'time cindy',year_ini_cas,mth_ini_cas,day_ini_cas
-      call ymds2ju                                                         &
-     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas &
-     & ,day_ju_ini_cas)
-      print*,'time cindy 2',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
-
-      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,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/))
-      call suphel
-      call infotrac_init 
-
-      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)) 
-
-!
-!   No ozone climatology need be read in this pre-initialization
-!          (phys_state_var_init is called again in physiq)
-      read_climoz = 0
-!
-      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.)
-      rlat=xlat
-      rlon=xlon
-      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'
-      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))
-!cc      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"
-
-      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
-      ts_cur = 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(:)=rlat(:)*rpi/180.
-      rlon_rad(:)=rlon(:)*rpi/180.
-
-      call iniphysiq(iim,jjm,llm,rday,day_ini,timestep,                        &
-     &     rlat_rad,rlon_rad,airefi,zcufi,zcvfi,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,:)=0.        ! couverture de neige des sous surface
-        qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
-        evap=0.
-        frugs(1,:)=rugos     ! 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(qsol, fder, snsrf, qsurfsrf,                  &
-     &                                    evap, frugs, agesno, 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.
-        else
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=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
-        nsw=6 ! on met le nb de bandes SW=6, pour initialiser
-              ! 6 albedo, mais on peut quand meme tourner avec
-              ! moins. Seules les 2 ou 4 premiers seront lus
-        falb1 = albedo                            
-        falb2 = albedo                            
-        falb_dir=albedo
-        falb_dif=albedo
-        rugoro=rugos 
-        t_ancien(1,:)=temp(:)
-        q_ancien(1,:)=q(:,1)
-        pbl_tke=1.e-8
-
-        rain_fall=0.
-        snow_fall=0.
-        solsw=0.
-        sollw=0.
-        radsol=0.
-        rnebcon=0.
-        ratqs=0.
-        clwcon=0.
-        zmea=0.
-        zstd=0.
-        zsig=0.
-        zgam=0.
-        zval=0. 
-        zthe=0. 
-        sig1=0.
-        w01=0.
-        u_ancien(1,:)=u(:)
-        v_ancien(1,:)=v(:)
- 
-!------------------------------------------------------------------------
-! 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,falb1(:,nsrf),falb2(:,nsrf),evap(:,nsrf),snow(:,nsrf)
-! radsol,solsw,sollw,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,wake_cstar,wake_fip
-!------------------------------------------------------------------------
-!Al1 =============== restart option ==========================
-        if (.not.restart) then
-          call phyredem ("startphy.nc")
-        else
-! (desallocations)
-        print*,'callin surf final'
-          call pbl_surface_final(qsol, fder, snsrf, qsurfsrf,               &
-     &                                    evap, frugs, agesno, 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,yd
-        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
-!
-!=====================================================================
-! START OF THE TEMPORAL LOOP :
-!=====================================================================
-           
-      do while(it.le.nint(fnday*day_step))
-
-       if (prt_level.ge.1) then
-         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
-     &                                it,day,time,nint(fnday*day_step)
-         print*,'PAS DE TEMPS ',timestep
-       endif
-!Al1 demande de restartphy.nc
-       if (it.eq.nint(fnday*day_step)) lastcall=.True.
-
-!---------------------------------------------------------------------
-! Interpolation of forcings in time and onto model levels
-!---------------------------------------------------------------------
-
-#include "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
-         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,                                     &
-     &              day,time,timestep,                                      &
-     &              plev,play,phi,phis,presnivs,                            &
-     &              u,v,temp,q,omega2,                                      &
-     &              du_phys,dv_phys,dt_phys,dq,dpsrf,                        &
-     &              dudyn)
-        firstcall=.false.
-
-!---------------------------------------------------------------------
-! Listing output for debug prt_level>=1
-!---------------------------------------------------------------------
-        if (prt_level>=1) 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_th_adv=0.0
-         d_q_adv=0.0
-       endif
-
-       if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
-     &    .or.forcing_amma) then
-         fcoriolis=0.0 ; ug=0. ; vg=0.
-       endif
-         if(forcing_rico) then
-          dt_cooling=0.
-        endif
-
-      print*, 'fcoriolis ', fcoriolis, xlat
-
-        du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
-       dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
-
-!!!!!!!!!!!!!!!!!!!!!!!!
-! Geostrophic wind
-!!!!!!!!!!!!!!!!!!!!!!!!
-       sfdt = sin(0.5*fcoriolis*timestep)
-       cfdt = cos(0.5*fcoriolis*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
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!         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
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 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.1) then
-          print *,                                                          &
-     &    'physiq-> temp(1),dt_phys(1),d_th_adv(1),dt_cooling(1) ',         &
-     &              temp(1),dt_phys(1),d_th_adv(1),dt_cooling(1)
-           print*,du_phys
-           print*, v
-           print*, vg
-        endif
-
-        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
-     &              dt_phys(1:mxcalc)                                       &
-     &             +d_th_adv(1:mxcalc)                                      &
-     &             +d_t_nudge(1:mxcalc)                                      &
-     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
-
-      endif  ! forcing_sandu or forcing_astex
-
-        teta=temp*(pzero/play)**rkappa
-!
-!---------------------------------------------------------------------
-!   Nudge soil temperature if requested
-!---------------------------------------------------------------------
-
-      IF (nudge_tsoil) 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)
-
-!---------------------------------------------------------------------
-!   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
-
-#include "1DUTILS.h"
-#include "1Dconv.h"
-
-#endif
-
Index: LMDZ5/branches/testing/libf/phylmd/lsc_scav.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/lsc_scav.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/lsc_scav.F90	(revision 2298)
@@ -1,5 +1,9 @@
 !$Id $
 
-SUBROUTINE lsc_scav(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
+SUBROUTINE lsc_scav(pdtime,it,iflag_lscav,  &
+!jyg<
+                    aerosol,  &
+!>jyg
+                    oliq,flxr,flxs,rneb,beta_fisrt,  &
                     beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
                     d_tr_bcscav,d_tr_evap,qPrls) 
@@ -37,4 +41,5 @@
   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
@@ -172,5 +177,10 @@
   ENDDO
 
-    IF (it.gt.1) THEN                               !  aerosol   
+!jyg<
+!!    IF (it.gt.1) THEN                               !  aerosol   
+!! 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
+!>jyg
       frac_ev=frac_aer
     ELSE                                                !  gas
@@ -178,5 +188,8 @@
     ENDIF
 
-    IF(it.gt.1) then  ! aerosol
+!jyg<
+!!    IF (it.gt.1) THEN                               !  aerosol   
+    IF (aerosol(it)) THEN
+!>jyg
      DO k=1, klev
       DO i=1, klon 
@@ -214,5 +227,8 @@
 
 !  below-cloud impaction
-    IF(it.eq.1) then
+!jyg<
+!!    IF (it.eq.1) THEN
+    IF (.NOT.aerosol(it)) THEN
+!>jyg
       d_tr_bcscav(i,k,it)=0.
     ELSE
Index: LMDZ5/branches/testing/libf/phylmd/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_grid_phy_lmdz.F90	(revision 2274)
+++ 	(revision )
@@ -1,454 +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,SAVE :: nbp_lon  ! == iim
-  INTEGER,SAVE :: nbp_lat  ! == jjmp1
-  INTEGER,SAVE :: nbp_lev  ! == llm
-  INTEGER,SAVE :: klon_glo
-
-  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(iim,jjp1,llm)
-  IMPLICIT NONE
-  INTEGER, INTENT(in) :: iim
-  INTEGER, INTENT(in) :: jjp1
-  INTEGER, INTENT(in) :: llm
-  
-    nbp_lon=iim
-    nbp_lat=jjp1
-    nbp_lev=llm
-    klon_glo=(iim*jjp1)-2*(iim-1)
-  
-  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: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_mpi_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,203 +1,0 @@
-!
-!$Header$
-!
-MODULE mod_phys_lmdz_mpi_data
-  USE mod_const_mpi
-  
-  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_root
-  LOGICAL,SAVE :: is_mpi_root
-  LOGICAL,SAVE :: is_using_mpi
-  
-  
-  LOGICAL,SAVE :: is_north_pole
-  LOGICAL,SAVE :: is_south_pole
-  INTEGER,SAVE :: COMM_LMDZ_PHY
-
-CONTAINS
-  
-  SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
-  USE mod_const_mpi, ONLY : COMM_LMDZ
-  IMPLICIT NONE
-    INTEGER,INTENT(in) :: iim
-    INTEGER,INTENT(in) :: jjp1
-    INTEGER,INTENT(in) :: nb_proc
-    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
-    
-    INTEGER :: ierr
-    INTEGER :: klon_glo
-    INTEGER :: i
-    
-#ifdef CPP_MPI
-    is_using_mpi=.TRUE.
-#else
-    is_using_mpi=.FALSE.
-#endif
-    
-    if (iim.eq.1) then
-       klon_glo=1
-    else
-       klon_glo=iim*(jjp1-2)+2
-    endif
-    
-    COMM_LMDZ_PHY=COMM_LMDZ
-
-    IF (is_using_mpi) THEN    
-#ifdef CPP_MPI
-      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
-      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
-#endif
-    ELSE
-      mpi_size=1
-      mpi_rank=0
-    ENDIF
-    
-    IF (mpi_rank == 0) THEN
-      mpi_root = 0
-      is_mpi_root = .true.
-    ENDIF
-    
-    IF (mpi_rank == 0) THEN 
-      is_north_pole = .TRUE.
-    ELSE
-      is_north_pole = .FALSE.
-    ENDIF
-    
-    IF (mpi_rank == mpi_size-1) THEN
-      is_south_pole = .TRUE.
-    ELSE
-      is_south_pole = .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:nb_proc-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)+iim-1
-      ENDIF
-
-      jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1
-      ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1
-
-      
-      ij_para_end(i) = klon_mpi_para_end(i)+iim-1
-      jj_para_end(i) = (ij_para_end(i)-1)/iim + 1
-      ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 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
-    
-  END SUBROUTINE Init_phys_lmdz_mpi_data
-
-  SUBROUTINE print_module_data
-  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_root =', mpi_root
-    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
-    WRITE(lunout,*) 'is_north_pole =', is_north_pole
-    WRITE(lunout,*) 'is_south_pole =', is_south_pole
-    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
-  
-  END SUBROUTINE print_module_data
-  
-END MODULE mod_phys_lmdz_mpi_data
Index: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1902 +1,0 @@
-!
-!$Header$
-!
-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 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 
-  
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! 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 , mpi_root_x=>mpi_root
-    IMPLICIT NONE
-    
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var
-    INTEGER,INTENT(IN) :: nb
-    
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-    
-#ifdef CPP_MPI
-    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-        
-  END SUBROUTINE bcast_mpi_cgen
-
-
-      
-  SUBROUTINE bcast_mpi_igen(var,nb)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-#ifdef CPP_MPI
-    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-        
-  END SUBROUTINE bcast_mpi_igen
-
-
-
-  
-  SUBROUTINE bcast_mpi_rgen(var,nb)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-#ifdef CPP_MPI
-    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-    
-  END SUBROUTINE bcast_mpi_rgen
-  
-
-
-
-  SUBROUTINE bcast_mpi_lgen(var,nb)
-    USE mod_phys_lmdz_mpi_data ,  mpi_root_x=>mpi_root
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-#ifdef CPP_MPI
-    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-
-  END SUBROUTINE bcast_mpi_lgen
-
-  
-
-  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    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
-      
-#ifdef CPP_MPI 
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
-                      MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
-#endif
-
-  END SUBROUTINE scatter_mpi_igen
-
-  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-
-    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
-      
-#ifdef CPP_MPI 
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
-                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
-
-#endif
-
-  END SUBROUTINE scatter_mpi_rgen
-
-  
-  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-
-    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
-      
-#ifdef CPP_MPI
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
-                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
-#endif
-
-  END SUBROUTINE scatter_mpi_lgen  
-
-
-
-
-  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    
-    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
-    
-#ifdef CPP_MPI
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
-                     MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
-#endif
-
-                          
-    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 , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    
-    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
-
-#ifdef CPP_MPI
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
-                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
-#endif
-                          
-    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 , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
-  
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-
-    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
-    
-
-#ifdef CPP_MPI
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
-                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
-#endif
-                          
-    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 , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-   
-    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
-
-
-#ifdef CPP_MPI
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-            
-  END SUBROUTINE reduce_sum_mpi_igen
-  
-  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
-    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
-    USE mod_grid_phy_lmdz
-
-    IMPLICIT NONE
-
-#ifdef CPP_MPI
-    INCLUDE 'mpif.h'
-#endif
-    
-    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
-   
-#ifdef CPP_MPI
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
-#endif
-        
-  END SUBROUTINE reduce_sum_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) 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) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole) 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) 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) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole) 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) 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) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole) 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) 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) 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) 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) 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) 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) 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: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_omp_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,109 +1,0 @@
-!
-!$Id$
-!
-MODULE mod_phys_lmdz_omp_data
-
-  INTEGER,SAVE :: omp_size
-  INTEGER,SAVE :: omp_rank
-  LOGICAL,SAVE :: is_omp_root
-  LOGICAL,SAVE :: is_using_omp
-  
-  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
-  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin
-  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end    
-  
-  INTEGER,SAVE :: klon_omp
-  INTEGER,SAVE :: klon_omp_begin
-  INTEGER,SAVE :: klon_omp_end
-!$OMP  THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end)
-
-CONTAINS
-  
-  SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi)
-    USE dimphy
-    IMPLICIT NONE
-    INTEGER, INTENT(in) :: klon_mpi
-
-    INTEGER :: i
-
-    CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data'
-    CHARACTER (LEN=80) :: abort_message
-
-
-#ifdef CPP_OMP    
-    INTEGER :: OMP_GET_NUM_THREADS
-    EXTERNAL OMP_GET_NUM_THREADS
-    INTEGER :: OMP_GET_THREAD_NUM
-    EXTERNAL OMP_GET_THREAD_NUM
-#endif  
-
-#ifdef CPP_OMP
-!$OMP MASTER
-        is_using_omp=.TRUE.
-        omp_size=OMP_GET_NUM_THREADS()
-!$OMP END MASTER
-        omp_rank=OMP_GET_THREAD_NUM()    
-#else    
-    is_using_omp=.FALSE.
-    omp_size=1
-    omp_rank=0
-#endif
-
-   is_omp_root=.FALSE.
-!$OMP MASTER
-   IF (omp_rank==0) THEN
-     is_omp_root=.TRUE.
-   ELSE
-     abort_message = 'ANORMAL : OMP_MASTER /= 0'
-     CALL abort_gcm (modname,abort_message,1)
-   ENDIF
-!$OMP END MASTER
-
-
-!$OMP MASTER 
-    ALLOCATE(klon_omp_para_nb(0:omp_size-1))
-    ALLOCATE(klon_omp_para_begin(0:omp_size-1))
-    ALLOCATE(klon_omp_para_end(0:omp_size-1))
-    
-    DO i=0,omp_size-1
-      klon_omp_para_nb(i)=klon_mpi/omp_size
-      IF (i<MOD(klon_mpi,omp_size)) klon_omp_para_nb(i)=klon_omp_para_nb(i)+1
-    ENDDO
-    
-    klon_omp_para_begin(0) = 1
-    klon_omp_para_end(0) = klon_omp_para_nb(0)
-    
-    DO i=1,omp_size-1
-      klon_omp_para_begin(i)=klon_omp_para_end(i-1)+1
-      klon_omp_para_end(i)=klon_omp_para_begin(i)+klon_omp_para_nb(i)-1
-    ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-   
-    klon_omp=klon_omp_para_nb(omp_rank)
-    klon_omp_begin=klon_omp_para_begin(omp_rank)
-    klon_omp_end=klon_omp_para_end(omp_rank)
-    
-    CALL Print_module_data
-    
-  END SUBROUTINE Init_phys_lmdz_omp_data
-
-  SUBROUTINE Print_module_data
-  IMPLICIT NONE
-  INCLUDE "iniprint.h"
-
-!$OMP CRITICAL  
-  WRITE(lunout,*)'--------> TASK ',omp_rank
-  WRITE(lunout,*)'omp_size =',omp_size
-  WRITE(lunout,*)'omp_rank =',omp_rank
-  WRITE(lunout,*)'is_omp_root =',is_omp_root
-  WRITE(lunout,*)'klon_omp_para_nb =',klon_omp_para_nb
-  WRITE(lunout,*)'klon_omp_para_begin =',klon_omp_para_begin
-  WRITE(lunout,*)'klon_omp_para_end =',klon_omp_para_end    
-  WRITE(lunout,*)'klon_omp =',klon_omp
-  WRITE(lunout,*)'klon_omp_begin =',klon_omp_begin
-  WRITE(lunout,*)'klon_omp_end =',klon_omp_end    
-!$OMP END CRITICAL
-
-  END SUBROUTINE Print_module_data
-END MODULE mod_phys_lmdz_omp_data
Index: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_omp_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1064 +1,0 @@
-!
-!$Header$
-!
-MODULE mod_phys_lmdz_omp_transfert
-
-  PRIVATE
-  
-  INTEGER,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 
-
-
-  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_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 Check_buffer_r(size(VarOut))   
-    CALL gather_omp_rgen(VarIn,Varout,1,buffer_r)
-    
-  END SUBROUTINE gather_omp_r
-
-
-  SUBROUTINE gather_omp_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    CALL Check_buffer_r(size(VarOut))   
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r)
-        
-  END SUBROUTINE gather_omp_r1
-
-
-  SUBROUTINE gather_omp_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarOut))   
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r)
-    
-  END SUBROUTINE gather_omp_r2
-  
-
-  SUBROUTINE gather_omp_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    CALL Check_buffer_r(size(VarOut))       
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r)
-    
-  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
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!    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,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_omp,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-    REAL,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_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
-
-END MODULE mod_phys_lmdz_omp_transfert
Index: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,113 +1,0 @@
-!
-!$Header$
-!
-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(iim,jjp1,nb_proc,distrib)
-  IMPLICIT NONE
-    INTEGER,INTENT(in) :: iim
-    INTEGER,INTENT(in) :: jjp1
-    INTEGER,INTENT(in) :: nb_proc
-    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
-
-    CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
-!$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
-     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
-  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: LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/mod_phys_lmdz_transfert_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,1275 +1,0 @@
-!
-!$Header$
-!
-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 
-
-   
-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  
-
-   
-END MODULE mod_phys_lmdz_transfert_para
-
Index: LMDZ5/branches/testing/libf/phylmd/moy_undefSTD.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/moy_undefSTD.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/moy_undefSTD.F90	(revision 2298)
@@ -5,8 +5,14 @@
   USE netcdf
   USE dimphy
+#ifdef CPP_IOIPSL 
   USE phys_state_var_mod
+#endif
+
   USE phys_cal_mod, ONLY: mth_len
   IMPLICIT NONE
   include "clesphys.h"
+#ifdef CPP_IOIPSL 
+  REAL :: missing_val
+#endif
 
   ! ====================================================================
@@ -51,7 +57,10 @@
   REAL un_jour
   PARAMETER (un_jour=86400.)
-  REAL missing_val
+! REAL missing_val
 
-  missing_val = nf90_fill_real
+! missing_val = nf90_fill_real
+#ifndef CPP_XIOS
+      missing_val=missing_val_nf90
+#endif
 
   DO n = 1, nout
Index: LMDZ5/branches/testing/libf/phylmd/nuage.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/nuage.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/nuage.h	(revision 2298)
@@ -7,4 +7,6 @@
       REAL tau_cld_cv,coefw_cld_cv
 
+      REAL tmax_fonte_cv
+
       INTEGER iflag_t_glace,iflag_cld_cv
 
@@ -12,4 +14,4 @@
      &                  t_glace_min,exposant_glace,rei_min,rei_max,     &
      &                  tau_cld_cv,coefw_cld_cv,                        &
-     &                  iflag_t_glace,iflag_cld_cv
+     &                  iflag_t_glace,iflag_cld_cv,tmax_fonte_cv
 !$OMP THREADPRIVATE(/nuagecom/)
Index: LMDZ5/branches/testing/libf/phylmd/ocean_cpl_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/ocean_cpl_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/ocean_cpl_mod.F90	(revision 2298)
@@ -46,8 +46,8 @@
        windsp, fder_old, &
        itime, dtime, knon, knindex, &
-       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, &
+       ps, u1, v1, gustiness, &
        radsol, snow, agesno, &
        qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -65,4 +65,5 @@
 
     INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
 !    
 ! Input arguments  
@@ -77,5 +78,5 @@
     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)        :: cdragh, cdragq, cdragm
     REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
     REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
@@ -83,5 +84,5 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
 
 ! In/Output arguments
@@ -136,13 +137,13 @@
 
     CALL calcul_fluxs(knon, is_oce, dtime, &
-         tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
+         tsurf_cpl, p1lay, cal, beta, cdragh, cdragq, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         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)
     
 ! - Flux calculation at first modele level for U and V
     CALL calcul_flux_wind(knon, dtime, &
-         u0_cpl, v0_cpl, u1, v1, cdragm, &
+         u0_cpl, v0_cpl, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
@@ -185,5 +186,5 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, pctsrf, &
+       ps, u1, v1, gustiness, pctsrf, &
        radsol, snow, qsurf, &
        alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -200,4 +201,5 @@
 
     INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
 
 ! Input arguments
@@ -219,5 +221,5 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
 
@@ -279,8 +281,8 @@
 
     CALL calcul_fluxs(knon, is_sic, dtime, &
-         tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
+         tsurf_cpl, p1lay, cal, beta, cdragh, cdragh, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         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)
 
@@ -288,5 +290,5 @@
 ! - Flux calculation at first modele level for U and V
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
Index: LMDZ5/branches/testing/libf/phylmd/ocean_forced_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/ocean_forced_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/ocean_forced_mod.F90	(revision 2298)
@@ -13,9 +13,9 @@
   SUBROUTINE ocean_forced_noice( &
        itime, dtime, jour, knon, knindex, &
-       p1lay, cdragh, cdragm, precip_rain, precip_snow, &
+       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, &
        temp_air, spechum, &
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, &
+       ps, u1, v1, gustiness, &
        radsol, snow, agesno, & 
        qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -33,4 +33,6 @@
     USE indice_sol_mod
     INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
 
 ! Input arguments
@@ -40,5 +42,5 @@
     REAL, INTENT(IN)                         :: dtime
     REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
-    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    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
@@ -46,5 +48,5 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
 
 ! In/Output arguments
@@ -109,13 +111,13 @@
 ! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf
     CALL calcul_fluxs(knon, is_oce, dtime, &
-         tsurf_lim, p1lay, cal, beta, cdragh, ps, &
+         tsurf_lim, p1lay, cal, beta, cdragh, cdragq, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         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)
 
 ! - Flux calculation at first modele level for U and V
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
@@ -131,5 +133,5 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, &
+       ps, u1, v1, gustiness, &
        radsol, snow, qsol, agesno, tsoil, &
        qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -165,5 +167,5 @@
     REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)    :: ps
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
 
 ! In/Output arguments
@@ -231,13 +233,13 @@
     v1_lay(:) = v1(:) - v0(:)
     CALL calcul_fluxs(knon, is_sic, dtime, &
-         tsurf_tmp, p1lay, cal, beta, cdragh, ps, &
+         tsurf_tmp, p1lay, cal, beta, cdragh, cdragh, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         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)
 
 ! - Flux calculation at first modele level for U and V
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
Index: LMDZ5/branches/testing/libf/phylmd/ocean_slab_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/ocean_slab_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/ocean_slab_mod.F90	(revision 2298)
@@ -216,8 +216,8 @@
   SUBROUTINE ocean_slab_noice( & 
        itime, dtime, jour, knon, knindex, &
-       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, tsurf_in, &
+       ps, u1, v1, gustiness, tsurf_in, &
        radsol, snow, &
        qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -227,4 +227,5 @@
 
     INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
 
 ! Input arguments
@@ -236,5 +237,5 @@
     REAL, INTENT(IN)                     :: dtime
     REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
-    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
+    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
@@ -242,5 +243,5 @@
     REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)    :: ps
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
     REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
@@ -287,13 +288,13 @@
 
     CALL calcul_fluxs(knon, is_oce, dtime, &
-         tsurf_in, p1lay, cal, beta, cdragh, ps, &
+         tsurf_in, p1lay, cal, beta, cdragh, cdragq, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         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)
 
 ! - Flux calculation at first modele level for U and V
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
@@ -398,5 +399,5 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, &
+       ps, u1, v1, gustiness, &
        radsol, snow, qsurf, qsol, agesno, &
        alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -406,4 +407,5 @@
 
    INCLUDE "YOMCST.h"
+   INCLUDE "clesphys.h"
 
 ! Input arguments
@@ -420,5 +422,5 @@
     REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)    :: ps
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)    :: swnet
 
@@ -498,8 +500,8 @@
 ! calcul_fluxs (sens, lat etc)
     CALL calcul_fluxs(knon, is_sic, dtime, &
-        tsurf_in, p1lay, cal, beta, cdragh, ps, &
+        tsurf_in, p1lay, cal, beta, cdragh, cdragh, ps, &
         precip_rain, precip_snow, snow, qsurf,  &
-        radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-        AcoefH, AcoefQ, BcoefH, BcoefQ, &
+        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 
@@ -509,5 +511,5 @@
 ! calcul_flux_wind
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
Index: LMDZ5/branches/testing/libf/phylmd/pbl_surface_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/pbl_surface_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/pbl_surface_mod.F90	(revision 2298)
@@ -29,6 +29,4 @@
 
 ! Declaration of variables saved in restart file
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: qsol   ! water height in the soil (mm)
-  !$OMP THREADPRIVATE(qsol)
   REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: fder   ! flux drift
   !$OMP THREADPRIVATE(fder)
@@ -37,11 +35,4 @@
   REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: qsurf  ! humidity at surface
   !$OMP THREADPRIVATE(qsurf)
-  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: evap   ! evaporation at surface
-  !$OMP THREADPRIVATE(evap)
-  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: rugos  ! rugosity at surface (m)
-  !$OMP THREADPRIVATE(rugos)
-  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: agesno ! age of snow at surface
-  !$OMP THREADPRIVATE(agesno)
-! Correction pour le cas AMMA (PRIVATE)
   REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature
   !$OMP THREADPRIVATE(ftsoil)
@@ -51,6 +42,5 @@
 !****************************************************************************************
 !
-  SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
-       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+  SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
 
 ! This routine should be called after the restart file has been read.
@@ -65,11 +55,7 @@
 ! Input variables
 !****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(IN)                 :: qsol_rst
     REAL, DIMENSION(klon), INTENT(IN)                 :: fder_rst
     REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: snow_rst
     REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: qsurf_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: evap_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: rugos_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: agesno_rst
     REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst
 
@@ -86,7 +72,4 @@
 !
 !****************************************************************************************    
-    ALLOCATE(qsol(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
-
     ALLOCATE(fder(klon), stat=ierr)
     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
@@ -98,24 +81,11 @@
     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
 
-    ALLOCATE(evap(klon,nbsrf), stat=ierr)
-    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
-
-    ALLOCATE(rugos(klon,nbsrf), stat=ierr)
-    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
-
-    ALLOCATE(agesno(klon,nbsrf), stat=ierr)
-    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
-
     ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr)
     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
 
 
-    qsol(:)       = qsol_rst(:)
     fder(:)       = fder_rst(:)
     snow(:,:)     = snow_rst(:,:)
     qsurf(:,:)    = qsurf_rst(:,:)
-    evap(:,:)     = evap_rst(:,:)
-    rugos(:,:)    = rugos_rst(:,:)
-    agesno(:,:)   = agesno_rst(:,:)
     ftsoil(:,:,:) = ftsoil_rst(:,:,:)
 
@@ -174,4 +144,5 @@
        zsig,      lwdown_m,  pphi,     cldt,          &
        rain_f,    snow_f,    solsw_m,  sollw_m,       &
+       gustiness,                                     &
        t,         q,         u,        v,             &
 !!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
@@ -181,13 +152,7 @@
 !!!
        pplay,     paprs,     pctsrf,                  &
-!albedo SB >>>
-!       ts,        alb1, alb2,ustar, u10m, v10m,wstar, &
        ts,SFRWL,   alb_dir, alb_dif,ustar, u10m, v10m,wstar, &
-!albedo SB <<<
        cdragh,    cdragm,   zu1,    zv1,              &
-!albedo SB >>>
-!       alb1_m,    alb2_m,    zxsens,   zxevap,        &
        alb_dir_m,    alb_dif_m,  zxsens,   zxevap,    &
-!albedo SB <<<
        alb3_lic,  runoff,    snowhgt,   qsnow,     to_ice,    sissnow,  &
        zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
@@ -204,5 +169,5 @@
 !!!
        zcoefh,    zcoefm,    slab_wfbils,             &
-       qsol_d,    zq2m,      s_pblh,   s_plcl,        &
+       qsol,    zq2m,      s_pblh,   s_plcl,        &
 !!!
 !!! jyg le 08/02/2012
@@ -211,8 +176,8 @@
        s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
        s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
-       zxrugs,zustar,zu10m,  zv10m,    fder_print,    &
+       zustar,zu10m,  zv10m,    fder_print,    &
        zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
-       rugos_d,   agesno_d,  sollw,    solsw,         &
-       d_ts,      evap_d,    fluxlat,  t2m,           &
+       z0m, z0h,   agesno,  sollw,    solsw,         &
+       d_ts,      evap,    fluxlat,  t2m,           &
        wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
        dflux_t,   dflux_q,   zxsnow,                  &
@@ -263,5 +228,5 @@
 ! pplay----input-R- pression au milieu de couche (Pa)
 ! rlat-----input-R- latitude en degree
-! rugos----input-R- longeur de rugosite (en m)
+! z0m, z0h ----input-R- longeur de rugosite (en m)
 ! Martin
 ! zsig-----input-R- slope
@@ -334,4 +299,6 @@
     REAL, DIMENSION(klon),        INTENT(IN)        :: zsig    ! slope
     REAL, DIMENSION(klon),        INTENT(IN)        :: lwdown_m ! downward longwave radiation at mean s    
+    REAL, DIMENSION(klon),        INTENT(IN)        :: gustiness ! gustiness
+
     REAL, DIMENSION(klon),        INTENT(IN)        :: cldt    ! total cloud fraction
     REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pphi    ! geopotential (m2/s2)
@@ -356,6 +323,4 @@
                                                                    !wake and off-wake regions
 !albedo SB >>>
-!    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb1    ! albedo in visible SW interval
-!    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb2    ! albedo in near infra-red SW interval
     REAL, DIMENSIOn(6),intent(in) :: SFRWL
     REAL, DIMENSION(klon, nsw, nbsrf), INTENT(INOUT)     :: alb_dir,alb_dif
@@ -382,8 +347,4 @@
     REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1        ! v wind speed in first layer
 !albedo SB >>>
-!    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb1_m     ! mean albedo
-!    in visible SW interval
-!    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb2_m     ! mean albedo
-!    in near IR SW interval
     REAL, DIMENSION(klon, nsw),        INTENT(OUT)       :: alb_dir_m,alb_dif_m
 !albedo SB <<<
@@ -434,5 +395,5 @@
 !!! 
     REAL, DIMENSION(klon),        INTENT(OUT)       :: slab_wfbils! heat balance at surface only for slab at ocean points
-    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d     ! water height in the soil (mm)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol     ! water height in the soil (mm)
     REAL, DIMENSION(klon),        INTENT(OUT)       :: zq2m       ! water vapour at 2m, mean for each grid point
     REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblh     ! height of the planetary boundary layer(HPBL)
@@ -454,5 +415,4 @@
     REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb2    ! inhibition, mean for each grid point
     REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb3    ! point Omega, mean for each grid point
-    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxrugs     ! rugosity at surface (m), mean for each grid point
     REAL, DIMENSION(klon),        INTENT(OUT)       :: zustar     ! u*
     REAL, DIMENSION(klon),        INTENT(OUT)       :: zu10m      ! u speed at 10m, mean for each grid point
@@ -463,10 +423,10 @@
     REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxu    ! u wind tension, mean for each grid point
     REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxv    ! v wind tension, mean for each grid point
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: rugos_d    ! rugosity length (m)
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: agesno_d   ! age of snow at surface
+    REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT)     :: z0m,z0h      ! rugosity length (m)
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)       :: agesno   ! age of snow at surface
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: solsw      ! net shortwave radiation at surface 
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: sollw      ! net longwave radiation at surface
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: d_ts       ! change in temperature at surface
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: evap_d     ! evaporation at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)       :: evap     ! evaporation at surface
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: fluxlat    ! latent flux
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m        ! temperature at 2 meter height
@@ -519,7 +479,6 @@
     REAL                               :: f1 ! fraction de longeurs visibles parmi tout SW intervalle
     REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
-    REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
+    REAL, DIMENSION(klon)              :: yts, yz0m, yz0h, ypct
 !albedo SB >>>
-!   REAL, DIMENSION(klon)              :: yalb, yalb1, yalb2
     REAL, DIMENSION(klon)              :: yalb,yalb_vis
 !albedo SB <<<
@@ -559,5 +518,5 @@
     REAL, DIMENSION(klon)              :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon)              :: ypsref
-    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb1_new, yalb2_new, yalb3_new
+    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb3_new
 !albedo SB >>>
     REAL, DIMENSION(klon,nsw)          :: yalb_dir_new, yalb_dif_new
@@ -795,4 +754,5 @@
     REAL, DIMENSION(klon, nbsrf)       :: alb          ! mean albedo for whole SW interval
     REAL, DIMENSION(klon)              :: ylwdown      ! jg : temporary (ysollwdown)
+    REAL, DIMENSION(klon)              :: ygustiness      ! jg : temporary (ysollwdown)
 
     REAL                               :: zx_qs1, zcor1, zdelta1 
@@ -823,4 +783,5 @@
 
     IF (first_call) THEN
+       print*,'PBL SURFACE AVEC GUSTINESS'
        first_call=.FALSE.
       
@@ -877,5 +838,4 @@
  zu1(:)=0. ; zv1(:)=0.
 !albedo SB >>>
-! alb1_m(:)=0. ; alb2_m(:)=0. ; alb3_lic(:)=0.
   alb_dir_m=0. ; alb_dif_m=0. ; alb3_lic(:)=0.
 !albedo SB <<<
@@ -890,5 +850,4 @@
  kh(:)=0. ; kh_x(:)=0. ; kh_w(:)=0.
  slab_wfbils(:)=0.
- qsol_d(:)=0.
  s_pblh(:)=0. ; s_pblh_x(:)=0. ; s_pblh_w(:)=0.
  s_plcl(:)=0. ; s_plcl_x(:)=0. ; s_plcl_w(:)=0.
@@ -896,13 +855,12 @@
  s_therm(:)=0.
  s_trmb1(:)=0. ; s_trmb2(:)=0. ; s_trmb3(:)=0.
- zxrugs(:)=0. ; zustar(:)=0.
+ zustar(:)=0.
  zu10m(:)=0. ; zv10m(:)=0.
  fder_print(:)=0.
  zxqsurf(:)=0.
  zxfluxu(:,:)=0. ; zxfluxv(:,:)=0.
- rugos_d(:,:)=0. ; agesno_d(:,:)=0.
  solsw(:,:)=0. ; sollw(:,:)=0.
  d_ts(:,:)=0.
- evap_d(:,:)=0.
+ evap(:,:)=0.
  fluxlat(:,:)=0.
  wfbils(:,:)=0. ; wfbilo(:,:)=0.
@@ -943,11 +901,10 @@
 !!    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
     ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0
-!!    zv1 = 0.0     ; yqsurf = 0.0     ; yalb1 = 0.0     ; yalb2 = 0.0    
+!!    zv1 = 0.0     ; yqsurf = 0.0
 !albedo SB >>>
-!    yqsurf = 0.0  ; yalb1 = 0.0      ; yalb2 = 0.0    
     yqsurf = 0.0  ; yalb = 0.0 ; yalb_vis = 0.0
 !albedo SB <<<
     yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0    
-    ysollw = 0.0  ; yrugos = 0.0     ; yu1 = 0.0    
+    ysollw = 0.0  ; yz0m = 0.0 ; yz0h = 0.0    ; yu1 = 0.0    
     yv1 = 0.0     ; ypaprs = 0.0     ; ypplay = 0.0
     ydelp = 0.0   ; yu = 0.0         ; yv = 0.0        ; yt = 0.0         
@@ -1077,9 +1034,8 @@
 !****************************************************************************************
 
-    zxrugs(:) = 0.0
     DO nsrf = 1, nbsrf
        DO i = 1, klon
-          rugos(i,nsrf) = MAX(rugos(i,nsrf),0.000015)
-          zxrugs(i) = zxrugs(i) + rugos(i,nsrf)*pctsrf(i,nsrf)
+          z0m(i,nsrf) = MAX(z0m(i,nsrf),z0min)
+          z0h(i,nsrf) = MAX(z0h(i,nsrf),z0min)
        ENDDO
     ENDDO
@@ -1087,23 +1043,8 @@
 ! Mean calculations of albedo
 !
-! Albedo at sub-surface
-! * alb1 : albedo in visible SW interval
-! * alb2 : albedo in near infrared SW interval
 ! * alb  : mean albedo for whole SW interval
 !
 ! Mean albedo for grid point
-! * alb1_m : albedo in visible SW interval
-! * alb2_m : albedo in near infrared SW interval
 ! * alb_m  : mean albedo at whole SW interval
-
-!albedo SB >>>
-!    alb1_m(:) = 0.0
-!    alb2_m(:) = 0.0
-!    DO nsrf = 1, nbsrf
-!       DO i = 1, klon
-!          alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf)
-!          alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf)
-!       ENDDO
-!    ENDDO
 
     alb_dir_m(:,:) = 0.0
@@ -1123,15 +1064,4 @@
 !    f1 = 1    ! put f1=1 to recreate old calculations
 
-!    DO nsrf = 1, nbsrf
-!       DO i = 1, klon
-!          alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf)
-!       ENDDO
-!    ENDDO
-!
-!    DO i = 1, klon
-!       alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i)
-!    END DO
-
-
 !f1 is already included with SFRWL values in each surf files
     alb=0.0
@@ -1177,5 +1107,4 @@
        ENDDO
     ENDDO
-
 
 !****************************************************************************************
@@ -1231,6 +1160,4 @@
           yalb(j)    = alb(i,nsrf)
 !albedo SB >>>
-!         yalb1(j)   = alb1(i,nsrf)
-!         yalb2(j)   = alb2(i,nsrf)
           yalb_vis(j) = alb_dir(i,1,nsrf)
           if(nsw==6)then
@@ -1244,7 +1171,9 @@
           yfder(j)   = fder(i)
           ylwdown(j) = lwdown_m(i)
+          ygustiness(j) = gustiness(i)
           ysolsw(j)  = solsw(i,nsrf)
           ysollw(j)  = sollw(i,nsrf)
-          yrugos(j)  = rugos(i,nsrf)
+          yz0m(j)  = z0m(i,nsrf)
+          yz0h(j)  = z0h(i,nsrf)
           yrugoro(j) = rugoro(i)
           yu1(j)     = u(i,1)
@@ -1377,5 +1306,5 @@
         CALL cdrag(knon, nsrf, &
             speed, yt(:,1), yq(:,1), zgeo1, ypaprs(:,1),&
-            yts, yqsurf, yrugos, &
+            yts, yqsurf, yz0m, yz0h, &
             ycdragm, ycdragh, zri1, pref )
 
@@ -1408,5 +1337,5 @@
         CALL cdrag(knon, nsrf, &
             speed_x, yt_x(:,1), yq_x(:,1), zgeo1_x, ypaprs(:,1),&
-            yts_x, yqsurf, yrugos, &
+            yts_x, yqsurf, yz0m, yz0h, &
             ycdragm_x, ycdragh_x, zri1_x, pref_x )
 
@@ -1422,8 +1351,20 @@
         IF (prt_level >=10) print *,'clcdrag -> ycdragh_x ', ycdragh_x
 !
-        CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
-            yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), &
-            yts_w, yqsurf, yrugos, &
-            ycdragm_w, ycdragh_w )
+! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
+!        CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
+!            yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), &
+!            yts_w, yqsurf, yz0m, &
+!            ycdragm_w, ycdragh_w )
+! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
+        DO i = 1, knon
+           zgeo1_w(i) = RD * yt_w(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
+                * (ypaprs(i,1)-ypplay(i,1))
+           speed_w(i) = SQRT(yu_w(i,1)**2+yv_w(i,1)**2)
+        END DO
+        CALL cdrag(knon, nsrf, &
+            speed_w, yt_w(:,1), yq_w(:,1), zgeo1_w, ypaprs(:,1),&
+            yts_w, yqsurf, yz0m, yz0h, &
+            ycdragm_w, ycdragh_w, zri1_w, pref_w )
+
 ! --- special Dice. JYG+MPL 25112013
         IF (ok_prescr_ust) then
@@ -1456,5 +1397,5 @@
       print *,' args coef_diff_turb: yt ',  yt  
       print *,' args coef_diff_turb: yts ', yts  
-      print *,' args coef_diff_turb: yrugos ', yrugos  
+      print *,' args coef_diff_turb: yz0m ', yz0m  
       print *,' args coef_diff_turb: yqsurf ', yqsurf  
       print *,' args coef_diff_turb: ycdragm ', ycdragm
@@ -1463,5 +1404,5 @@
        ENDIF
         CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
-            ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
+            ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
             ycoefm, ycoefh, ytke)
        IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
@@ -1484,5 +1425,4 @@
       print *,' args coef_diff_turb: yt_x ',  yt_x  
       print *,' args coef_diff_turb: yts_x ', yts_x  
-      print *,' args coef_diff_turb: yrugos ', yrugos  
       print *,' args coef_diff_turb: yqsurf ', yqsurf  
       print *,' args coef_diff_turb: ycdragm_x ', ycdragm_x
@@ -1491,5 +1431,5 @@
        ENDIF
         CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
-            ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yrugos, yqsurf, ycdragm_x, &
+            ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yqsurf, ycdragm_x, &
             ycoefm_x, ycoefh_x, ytke_x)
        IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
@@ -1511,5 +1451,4 @@
       print *,' args coef_diff_turb: yt_w ',  yt_w  
       print *,' args coef_diff_turb: yts_w ', yts_w  
-      print *,' args coef_diff_turb: yrugos ', yrugos  
       print *,' args coef_diff_turb: yqsurf ', yqsurf  
       print *,' args coef_diff_turb: ycdragm_w ', ycdragm_w
@@ -1518,5 +1457,5 @@
        ENDIF
         CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
-            ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yrugos, yqsurf, ycdragm_w, &
+            ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yqsurf, ycdragm_w, &
             ycoefm_w, ycoefh_w, ytke_w)
        IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
@@ -1779,5 +1718,5 @@
           CALL stdlevvar(klon, knon, is_ter, zxli, &
                yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, &
-               yts, yqsurf, yrugos, ypaprs(:,1), ypplay(:,1), &
+               yts, yqsurf, yz0m, yz0h, ypaprs(:,1), ypplay(:,1), &
                yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
           
@@ -1801,11 +1740,8 @@
                AcoefH, AcoefQ, BcoefH, BcoefQ, & 
                AcoefU, AcoefV, BcoefU, BcoefV, & 
-               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
                ylwdown, yq2m, yt2m, &
                ysnow, yqsol, yagesno, ytsoil, &
-!albedo SB >>>
-!              yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
-               yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
-!albedo SB <<<
+               yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
                yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
                y_flux_u1, y_flux_v1 )
@@ -1818,6 +1754,4 @@
 !         ytsoil(:,:)=300.
 !         yz0_new(:)=0.001
-!         yalb1_new(:)=0.22
-!         yalb2_new(:)=0.22
 !         yevap(:)=flat/RLVTT
 !         yfluxlat(:)=-flat
@@ -1841,10 +1775,7 @@
                AcoefH, AcoefQ, BcoefH, BcoefQ, &
                AcoefU, AcoefV, BcoefU, BcoefV, &
-               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
                ysnow, yqsurf, yqsol, yagesno, &
-!albedo SB >>>
-!              ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
-               ytsoil, yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap,yfluxsens,yfluxlat, &
-!albedo SB <<<
+               ytsoil, yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap,yfluxsens,yfluxlat, &
                ytsurf_new, y_dflux_t, y_dflux_q, &
                yzsig, ycldt, &
@@ -1852,14 +1783,4 @@
                yalb3_new, yrunoff, &
                y_flux_u1, y_flux_v1)
-          !CALL surf_landice(itap, dtime, knon, ni, &
-          !     ysolsw, ysollw, yts, ypplay(:,1), &
-          !     ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
-          !     AcoefH, AcoefQ, BcoefH, BcoefQ, &
-          !     AcoefU, AcoefV, BcoefU, BcoefV, &
-          !     ypsref, yu1, yv1, yrugoro, pctsrf, &
-          !     ysnow, yqsurf, yqsol, yagesno, &
-          !     ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
-          !     ytsurf_new, y_dflux_t, y_dflux_q, &
-          !     y_flux_u1, y_flux_v1)
 
 !jyg<
@@ -1878,19 +1799,13 @@
           
        CASE(is_oce)
-!albedo SB >>>
-!          CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
            CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, &
-!albedo SB <<<
-               yrugos, ywindsp, rmu0, yfder, yts, &
+               ywindsp, rmu0, yfder, yts, &
                itap, dtime, jour, knon, ni, &
-               ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
                AcoefH, AcoefQ, BcoefH, BcoefQ, &
                AcoefU, AcoefV, BcoefU, BcoefV, &
-               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
                ysnow, yqsurf, yagesno, &
-!albedo SB >>>
-!              yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
-               yz0_new, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
-!albedo SB <<<
+               yz0m, yz0h, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
                ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, &
                y_flux_u1, y_flux_v1)
@@ -1914,5 +1829,4 @@
           CALL surf_seaice( &
 !albedo SB >>>
-!               rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
                rlon, rlat, ysolsw, ysollw, yalb_vis, yfder, &
 !albedo SB <<<
@@ -1922,9 +1836,8 @@
                AcoefH, AcoefQ, BcoefH, BcoefQ, &
                AcoefU, AcoefV, BcoefU, BcoefV, &
-               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ypsref, yu1, yv1, ygustiness, pctsrf, &
                ysnow, yqsurf, yqsol, yagesno, ytsoil, &
 !albedo SB >>>
-!               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
-               yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
+               yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
 !albedo SB <<<
                ytsurf_new, y_dflux_t, y_dflux_q, &
@@ -2298,6 +2211,4 @@
           d_ts(i,nsrf) = y_d_ts(j)
 !albedo SB >>>
-!          alb1(i,nsrf) = yalb1_new(j)  
-!          alb2(i,nsrf) = yalb2_new(j)
           do k=1,nsw
           alb_dir(i,k,nsrf) = yalb_dir_new(j,k)
@@ -2307,5 +2218,6 @@
           snow(i,nsrf) = ysnow(j)  
           qsurf(i,nsrf) = yqsurf(j)
-          rugos(i,nsrf) = yz0_new(j)
+          z0m(i,nsrf) = yz0m(j)
+          z0h(i,nsrf) = yz0h(j)
           fluxlat(i,nsrf) = yfluxlat(j)
           agesno(i,nsrf) = yagesno(j)  
@@ -2519,7 +2431,7 @@
        DO j=1, knon
           i = ni(j)
-          rugo1(j) = yrugos(j)
+          rugo1(j) = yz0m(j)
           IF(nsrf.EQ.is_oce) THEN
-             rugo1(j) = rugos(i,nsrf)
+             rugo1(j) = z0m(i,nsrf)
           ENDIF
           psfce(j)=ypaprs(j,1)
@@ -2536,14 +2448,14 @@
         CALL stdlevvar(klon, knon, nsrf, zxli, &
             uzon, vmer, tair1, qair1, zgeo1, &
-            tairsol, qairsol, rugo1, psfce, patm, &
+            tairsol, qairsol, rugo1, rugo1, psfce, patm, &
             yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
        ELSE  !(iflag_split .eq.0)
         CALL stdlevvar(klon, knon, nsrf, zxli, &
             uzon_x, vmer_x, tair1_x, qair1_x, zgeo1_x, &
-            tairsol_x, qairsol, rugo1, psfce, patm, &
+            tairsol_x, qairsol, rugo1, rugo1, psfce, patm, &
             yt2m_x, yq2m_x, yt10m_x, yq10m_x, yu10m_x, yustar_x)
         CALL stdlevvar(klon, knon, nsrf, zxli, &
             uzon_w, vmer_w, tair1_w, qair1_w, zgeo1_w, &
-            tairsol_w, qairsol, rugo1, psfce, patm, &
+            tairsol_w, qairsol, rugo1, rugo1, psfce, patm, &
             yt2m_w, yq2m_w, yt10m_w, yq10m_w, yu10m_w, yustar_w)
 !!!
@@ -2771,4 +2683,13 @@
 !****************************************************************************************
     
+    z0m(:,nbsrf+1) = 0.0
+    z0h(:,nbsrf+1) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          z0m(i,nbsrf+1) = z0m(i,nbsrf+1) + z0m(i,nsrf)*pctsrf(i,nsrf)
+          z0h(i,nbsrf+1) = z0h(i,nbsrf+1) + z0h(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
 !   print*,'OK pbl 7'
     zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
@@ -2987,10 +2908,4 @@
     zv1(:) = v(:,1)
 
-! Some of the module declared variables are returned for printing in physiq.F
-    qsol_d(:)     = qsol(:)
-    evap_d(:,:)   = evap(:,:)
-    rugos_d(:,:)  = rugos(:,:) 
-    agesno_d(:,:) = agesno(:,:)
-
 
   END SUBROUTINE pbl_surface
@@ -2998,6 +2913,5 @@
 !****************************************************************************************
 !
-  SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
-       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+  SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
 
     USE indice_sol_mod
@@ -3007,11 +2921,7 @@
 ! Ouput variables
 !****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)                 :: qsol_rst
     REAL, DIMENSION(klon), INTENT(OUT)                 :: fder_rst
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: snow_rst
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: qsurf_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: evap_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: rugos_rst
-    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: agesno_rst
     REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst
 
@@ -3021,11 +2931,7 @@
 !
 !****************************************************************************************    
-    qsol_rst(:)       = qsol(:)
     fder_rst(:)       = fder(:)
     snow_rst(:,:)     = snow(:,:)
     qsurf_rst(:,:)    = qsurf(:,:)
-    evap_rst(:,:)     = evap(:,:)
-    rugos_rst(:,:)    = rugos(:,:)
-    agesno_rst(:,:)   = agesno(:,:)
     ftsoil_rst(:,:,:) = ftsoil(:,:,:)
 
@@ -3035,11 +2941,7 @@
 !****************************************************************************************
 !   DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
-    IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
     IF (ALLOCATED(fder)) DEALLOCATE(fder)
     IF (ALLOCATED(snow)) DEALLOCATE(snow)
     IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf)
-    IF (ALLOCATED(evap)) DEALLOCATE(evap)
-    IF (ALLOCATED(rugos)) DEALLOCATE(rugos)
-    IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
     IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil)
 
@@ -3050,6 +2952,7 @@
 
 !albedo SB >>>
-!  SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, tke)
-SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke)  
+SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, &
+     evap, z0m, z0h, agesno,                                  &
+     tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke)  
 !albedo SB <<<
     ! Give default values where new fraction has appread
@@ -3070,9 +2973,10 @@
     REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: tsurf
 !albedo SB >>>
-!   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: alb1, alb2
     REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT)       :: alb_dir, alb_dif 
     INTEGER :: k
 !albedo SB <<<
     REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: ustar,u10m, v10m
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: evap, agesno
+    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT)        :: z0m,z0h
     REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke
 
@@ -3116,9 +3020,8 @@
                 qsurf(i,nsrf) = qsurf(i,nsrf_comp1)
                 evap(i,nsrf)  = evap(i,nsrf_comp1)
-                rugos(i,nsrf) = rugos(i,nsrf_comp1)
+                z0m(i,nsrf) = z0m(i,nsrf_comp1)
+                z0h(i,nsrf) = z0h(i,nsrf_comp1)
                 tsurf(i,nsrf) = tsurf(i,nsrf_comp1)
 !albedo SB >>>
-!                alb1(i,nsrf)  = alb1(i,nsrf_comp1)
-!                alb2(i,nsrf)  = alb2(i,nsrf_comp1)
                 DO k=1,nsw
                  alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp1)
@@ -3137,9 +3040,8 @@
                 qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
                 evap(i,nsrf)  = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
-                rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                z0m(i,nsrf) = z0m(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0m(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                z0h(i,nsrf) = z0h(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0h(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
                 tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
 !albedo SB >>>
-!                alb1(i,nsrf)  = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
-!                alb2(i,nsrf)  = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
                 DO k=1,nsw
                  alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&
Index: LMDZ5/branches/testing/libf/phylmd/phyaqua_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phyaqua_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phyaqua_mod.F90	(revision 2298)
@@ -48,9 +48,7 @@
     REAL :: run_off_lic_0(nlon)
     REAL :: qsolsrf(nlon, nbsrf), snsrf(nlon, nbsrf)
-    REAL :: frugs(nlon, nbsrf)
-    REAL :: agesno(nlon, nbsrf)
     REAL :: tsoil(nlon, nsoilmx, nbsrf)
     REAL :: tslab(nlon), seaice(nlon)
-    REAL evap(nlon, nbsrf), fder(nlon)
+    REAL fder(nlon)
 
 
@@ -67,5 +65,5 @@
     REAL tsurf
     REAL time, timestep, day, day0
-    REAL qsol_f, qsol(nlon)
+    REAL qsol_f
     REAL rugsrel(nlon)
     ! real zmea(nlon),zstd(nlon),zsig(nlon)
@@ -328,5 +326,5 @@
     seaice(:) = 0.
     run_off_lic_0 = 0.
-    evap = 0.
+    fevap = 0.
 
 
@@ -336,9 +334,9 @@
     qsolsrf(:, :) = qsol(1) ! humidite du sol des sous surface
     snsrf(:, :) = 0. ! couverture de neige des sous surface
-    frugs(:, :) = rugos ! couverture de neige des sous surface
-
-
-    CALL pbl_surface_init(qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, &
-      tsoil)
+    z0m(:, :) = rugos ! couverture de neige des sous surface
+    z0h=z0m
+
+
+    CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil)
 
     PRINT *, 'iniaqua: before phyredem'
Index: LMDZ5/branches/testing/libf/phylmd/phyetat0.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phyetat0.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phyetat0.F90	(revision 2298)
@@ -10,5 +10,6 @@
   USE surface_data,     ONLY : type_ocean, version_ocean
   USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, dtime, &
-       du_gwd_rando, dv_gwd_rando, entr_therm, f0, falb1, falb2, fm_therm, &
+       qsol, fevap, z0m, z0h, agesno, &
+       du_gwd_rando, dv_gwd_rando, entr_therm, f0, fm_therm, &
        falb_dir, falb_dif, &
        ftsol, pbl_tke, pctsrf, q_ancien, radpas, radsol, rain_fall, ratqs, &
@@ -20,5 +21,5 @@
        zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl
   USE iostart, ONLY : close_startphy, get_field, get_var, open_startphy
-  USE infotrac, only: nbtr, type_trac, tname, niadv
+  USE infotrac, only: nbtr, nqo, type_trac, tname, niadv
   USE traclmdz_mod,    ONLY : traclmdz_from_restart
   USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl, co2_send
@@ -46,10 +47,6 @@
   REAL tsoil(klon, nsoilmx, nbsrf)
   REAL qsurf(klon, nbsrf)
-  REAL qsol(klon)
   REAL snow(klon, nbsrf)
-  REAL evap(klon, nbsrf)
   real fder(klon)
-  REAL frugs(klon, nbsrf)
-  REAL agesno(klon, nbsrf)
   REAL run_off_lic_0(klon)
   REAL fractint(klon)
@@ -74,5 +71,5 @@
   CHARACTER*7 str7
   CHARACTER*2 str2
-  LOGICAL :: found
+  LOGICAL :: found,phyetat0_get,phyetat0_srf
 
   ! FH1D
@@ -205,353 +202,71 @@
   END DO
 
-  ! Lecture des temperatures du sol:
-
-  CALL get_field("TS", ftsol(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <TS> est absent'
-     PRINT*, '          Mais je vais essayer de lire TS**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
+!===================================================================
+! Lecture des temperatures du sol:
+!===================================================================
+
+  found=phyetat0_get(1,ftsol(:,1),"TS","Surface temperature",283.)
+  IF (found) THEN
+     DO nsrf=2,nbsrf
+        ftsol(:,nsrf)=ftsol(:,1)
+     ENDDO
+  ELSE
+     found=phyetat0_srf(1,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_gcm("phyetat0", "", 1)
         ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("TS"//str2, ftsol(:, nsrf))
-
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(ftsol(i, nsrf), xmin)
-           xmax = MAX(ftsol(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'Temperature du sol TS**:', nsrf, xmin, xmax
+        WRITE(str2, '(i2.2)') isw
+        found=phyetat0_srf(1,falb_dir(:, isw,:),"A_dir_SW"//str2//"srf","Direct Albedo",0.2)
+        found=phyetat0_srf(1,falb_dif(:, isw,:),"A_dif_SW"//str2//"srf","Direct Albedo",0.2)
      ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <TS> est present'
-     PRINT*, '          J ignore donc les autres temperatures TS**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(ftsol(i, 1), xmin)
-        xmax = MAX(ftsol(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Temperature du sol <TS>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           ftsol(i, nsrf) = ftsol(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-!===================================================================
-  ! Lecture des albedo difus et direct
-
-  DO nsrf = 1, nbsrf
-     DO isw=1, nsw
-        IF (isw.GT.99 .AND. nsrf.GT.99) THEN
-           PRINT*, "Trop de bandes SW ou sous-mailles"
+  ENDDO
+
+!===================================================================
+  ! Lecture des temperatures du sol profond:
+!===================================================================
+
+   DO isoil=1, nsoilmx
+        IF (isoil.GT.99) THEN
+           PRINT*, "Trop de couches "
            call abort_gcm("phyetat0", "", 1)
         ENDIF
-        WRITE(str7, '(i2.2, "srf", i2.2)') isw, nsrf
-
-        CALL get_field('A_dir_SW'//str7, falb_dir(:, isw, nsrf), found)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: Le champ <A_dir_SW"//str7//"> est absent"
-           PRINT*, "          Il prend donc la valeur de surface"
-           DO i=1, klon
-              falb_dir(i, isw, nsrf)=0.2
-           ENDDO
-        ENDIF
-        CALL get_field('A_dif_SW'//str7, falb_dif(:, isw, nsrf), found)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: Le champ <A_dif_SW"//str7//"> est absent"
-           PRINT*, "          Il prend donc la valeur de surface"
-           DO i=1, klon
-              falb_dif(i, isw, nsrf)=0.2
-           ENDDO
-        ENDIF
-     ENDDO
-  ENDDO
-
-!===================================================================
-  ! Lecture des temperatures du sol profond:
-
-  DO nsrf = 1, nbsrf
-     DO isoil=1, nsoilmx
-        IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
-           PRINT*, "Trop de couches ou sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str7, '(i2.2, "srf", i2.2)') isoil, nsrf
-
-        CALL get_field('Tsoil'//str7, tsoil(:, isoil, nsrf), found)
+        WRITE(str2,'(i2.2)') isoil
+        found=phyetat0_srf(1,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"
-           DO i=1, klon
-              tsoil(i, isoil, nsrf)=ftsol(i, nsrf)
-           ENDDO
+           tsoil(:, isoil, :)=ftsol(:, :)
         ENDIF
-     ENDDO
-  ENDDO
-
-!===================================================================
-  ! Lecture de l'humidite de l'air juste au dessus du sol:
-
-  CALL get_field("QS", qsurf(:, 1), found)
+   ENDDO
+
+!=======================================================================
+! Lecture precipitation/evaporation
+!=======================================================================
+
+  found=phyetat0_srf(1,qsurf,"QS","Near surface hmidity",0.)
+  found=phyetat0_get(1,qsol,"QSOL","Surface hmidity / bucket",0.)
+  found=phyetat0_srf(1,snow,"SNOW","Surface snow",0.)
+  found=phyetat0_srf(1,fevap,"EVAP","evaporation",0.)
+  found=phyetat0_get(1,snow_fall,"snow_f","snow fall",0.)
+  found=phyetat0_get(1,rain_fall,"rain_f","rain fall",0.)
+
+!=======================================================================
+! Radiation
+!=======================================================================
+
+  found=phyetat0_get(1,solsw,"solsw","net SW radiation surf",0.)
+  found=phyetat0_get(1,sollw,"sollw","net LW radiation surf",0.)
+  found=phyetat0_get(1,sollwdown,"sollwdown","down LW radiation surf",0.)
   IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <QS> est absent'
-     PRINT*, '          Mais je vais essayer de lire QS**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("QS"//str2, qsurf(:, nsrf))
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(qsurf(i, nsrf), xmin)
-           xmax = MAX(qsurf(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'Humidite pres du sol QS**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <QS> est present'
-     PRINT*, '          J ignore donc les autres humidites QS**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(qsurf(i, 1), xmin)
-        xmax = MAX(qsurf(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Humidite pres du sol <QS>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           qsurf(i, nsrf) = qsurf(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  ! Eau dans le sol (pour le modele de sol "bucket")
-
-  CALL get_field("QSOL", qsol, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <QSOL> est absent'
-     PRINT*, '          Valeur par defaut nulle'
-     qsol(:)=0.
-  ENDIF
-
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(qsol(i), xmin)
-     xmax = MAX(qsol(i), xmax)
-  ENDDO
-  PRINT*, 'Eau dans le sol (mm) <QSOL>', xmin, xmax
-
-  ! Lecture de neige au sol:
-
-  CALL get_field("SNOW", snow(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <SNOW> est absent'
-     PRINT*, '          Mais je vais essayer de lire SNOW**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field( "SNOW"//str2, snow(:, nsrf))
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(snow(i, nsrf), xmin)
-           xmax = MAX(snow(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'Neige du sol SNOW**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <SNOW> est present'
-     PRINT*, '          J ignore donc les autres neiges SNOW**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(snow(i, 1), xmin)
-        xmax = MAX(snow(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Neige du sol <SNOW>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           snow(i, nsrf) = snow(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  ! Lecture de albedo de l'interval visible au sol:
-
-  CALL get_field("ALBE", falb1(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <ALBE> est absent'
-     PRINT*, '          Mais je vais essayer de lire ALBE**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("ALBE"//str2, falb1(:, nsrf))
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(falb1(i, nsrf), xmin)
-           xmax = MAX(falb1(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'Albedo du sol ALBE**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <ALBE> est present'
-     PRINT*, '          J ignore donc les autres ALBE**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(falb1(i, 1), xmin)
-        xmax = MAX(falb1(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Neige du sol <ALBE>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           falb1(i, nsrf) = falb1(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  ! Lecture de albedo au sol dans l'interval proche infra-rouge:
-
-  CALL get_field("ALBLW", falb2(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
-     PRINT*, '          Mais je vais prendre ALBE**'
-     DO nsrf = 1, nbsrf
-        DO i = 1, klon
-           falb2(i, nsrf) = falb1(i, nsrf)
-        ENDDO
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <ALBLW> est present'
-     PRINT*, '          J ignore donc les autres ALBLW**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(falb2(i, 1), xmin)
-        xmax = MAX(falb2(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Neige du sol <ALBLW>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           falb2(i, nsrf) = falb2(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  ! Lecture de evaporation:  
-
-  CALL get_field("EVAP", evap(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <EVAP> est absent'
-     PRINT*, '          Mais je vais essayer de lire EVAP**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("EVAP"//str2, evap(:, nsrf))
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(evap(i, nsrf), xmin)
-           xmax = MAX(evap(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'evap du sol EVAP**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <EVAP> est present'
-     PRINT*, '          J ignore donc les autres EVAP**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(evap(i, 1), xmin)
-        xmax = MAX(evap(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Evap du sol <EVAP>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           evap(i, nsrf) = evap(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  ! Lecture precipitation liquide:
-
-  CALL get_field("rain_f", rain_fall)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(rain_fall(i), xmin)
-     xmax = MAX(rain_fall(i), xmax)
-  ENDDO
-  PRINT*, 'Precipitation liquide rain_f:', xmin, xmax
-
-  ! Lecture precipitation solide:
-
-  CALL get_field("snow_f", snow_fall)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(snow_fall(i), xmin)
-     xmax = MAX(snow_fall(i), xmax)
-  ENDDO
-  PRINT*, 'Precipitation solide snow_f:', xmin, xmax
-
-  ! Lecture rayonnement solaire au sol:
-
-  CALL get_field("solsw", solsw, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <solsw> est absent'
-     PRINT*, 'mis a zero'
-     solsw(:) = 0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(solsw(i), xmin)
-     xmax = MAX(solsw(i), xmax)
-  ENDDO
-  PRINT*, 'Rayonnement solaire au sol solsw:', xmin, xmax
-
-  ! Lecture rayonnement IF au sol:
-
-  CALL get_field("sollw", sollw, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <sollw> est absent'
-     PRINT*, 'mis a zero'
-     sollw = 0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(sollw(i), xmin)
-     xmax = MAX(sollw(i), xmax)
-  ENDDO
-  PRINT*, 'Rayonnement IF au sol sollw:', xmin, xmax
-
-  CALL get_field("sollwdown", sollwdown, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <sollwdown> est absent'
-     PRINT*, 'mis a zero'
-     sollwdown = 0.
-     zts=0.
+     sollwdown = 0. ;  zts=0.
      do nsrf=1,nbsrf
         zts(:)=zts(:)+ftsol(:,nsrf)*pctsrf(:,nsrf)
@@ -559,606 +274,84 @@
      sollwdown(:)=sollw(:)+RSIGMA*zts(:)**4
   ENDIF
-!  print*,'TS SOLL',zts(klon/2),sollw(klon/2),sollwdown(klon/2)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(sollwdown(i), xmin)
-     xmax = MAX(sollwdown(i), xmax)
-  ENDDO
-  PRINT*, 'Rayonnement IF au sol sollwdown:', xmin, xmax
-
-
-  ! Lecture derive des flux:
-
-  CALL get_field("fder", fder, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <fder> est absent'
-     PRINT*, 'mis a zero'
-     fder = 0.
+
+  found=phyetat0_get(1,radsol,"RADS","Solar radiation",0.)
+  found=phyetat0_get(1,fder,"fder","Flux derivative",0.) 
+
+
+  ! Lecture de la longueur de rugosite 
+  found=phyetat0_srf(1,z0m,"RUG","Z0m ancien",0.001)
+  IF (found) THEN
+     z0h(:,1:nbsrf)=z0m(:,1:nbsrf)
+  ELSE
+     found=phyetat0_srf(1,z0m,"Z0m","Roughness length, momentum ",0.001)
+     found=phyetat0_srf(1,z0h,"Z0h","Roughness length, enthalpy ",0.001)
   ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(fder(i), xmin)
-     xmax = MAX(fder(i), xmax)
-  ENDDO
-  PRINT*, 'Derive des flux fder:', xmin, xmax
-
-  ! Lecture du rayonnement net au sol:
-
-  CALL get_field("RADS", radsol)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(radsol(i), xmin)
-     xmax = MAX(radsol(i), xmax)
-  ENDDO
-  PRINT*, 'Rayonnement net au sol radsol:', xmin, xmax
-
-  ! Lecture de la longueur de rugosite 
-
-  CALL get_field("RUG", frugs(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <RUG> est absent'
-     PRINT*, '          Mais je vais essayer de lire RUG**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("RUG"//str2, frugs(:, nsrf))
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(frugs(i, nsrf), xmin)
-           xmax = MAX(frugs(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'rugosite du sol RUG**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <RUG> est present'
-     PRINT*, '          J ignore donc les autres RUG**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(frugs(i, 1), xmin)
-        xmax = MAX(frugs(i, 1), xmax)
-     ENDDO
-     PRINT*, 'rugosite <RUG>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           frugs(i, nsrf) = frugs(i, 1)
-        ENDDO
-     ENDDO
+
+  ! Lecture de l'age de la neige:
+  found=phyetat0_srf(1,agesno,"AGESNO","SNOW AGE",0.001)
+
+  ancien_ok=.true.
+  ancien_ok=ancien_ok.AND.phyetat0_get(klev,t_ancien,"TANCIEN","TANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(klev,q_ancien,"QANCIEN","QANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(klev,u_ancien,"UANCIEN","UANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(klev,v_ancien,"VANCIEN","VANCIEN",0.)
+
+  found=phyetat0_get(klev,clwcon,"CLWCON","CLWCON",0.)
+  found=phyetat0_get(klev,rnebcon,"RNEBCON","RNEBCON",0.)
+  found=phyetat0_get(klev,ratqs,"RATQS","RATQS",0.)
+
+  found=phyetat0_get(1,run_off_lic_0,"RUNOFFLIC0","RUNOFFLIC0",0.)
+
+!==================================
+!  TKE
+!==================================
+!
+  IF (iflag_pbl>1) then
+     found=phyetat0_srf(klev+1,pbl_tke,"TKE","Turb. Kinetic. Energ. ",1.e-8)
   ENDIF
 
-  ! Lecture de l'age de la neige:
-
-  CALL get_field("AGESNO", agesno(:, 1), found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
-     PRINT*, '          Mais je vais essayer de lire AGESNO**'
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("AGESNO"//str2, agesno(:, nsrf), found)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
-           agesno = 50.0
-        ENDIF
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO i = 1, klon
-           xmin = MIN(agesno(i, nsrf), xmin)
-           xmax = MAX(agesno(i, nsrf), xmax)
-        ENDDO
-        PRINT*, 'Age de la neige AGESNO**:', nsrf, xmin, xmax
-     ENDDO
-  ELSE
-     PRINT*, 'phyetat0: Le champ <AGESNO> est present'
-     PRINT*, '          J ignore donc les autres AGESNO**'
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO i = 1, klon
-        xmin = MIN(agesno(i, 1), xmin)
-        xmax = MAX(agesno(i, 1), xmax)
-     ENDDO
-     PRINT*, 'Age de la neige <AGESNO>', xmin, xmax
-     DO nsrf = 2, nbsrf
-        DO i = 1, klon
-           agesno(i, nsrf) = agesno(i, 1)
-        ENDDO
-     ENDDO
-  ENDIF
-
-  CALL get_field("ZMEA", zmea)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zmea(i), xmin)
-     xmax = MAX(zmea(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
-
-  CALL get_field("ZSTD", zstd)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zstd(i), xmin)
-     xmax = MAX(zstd(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
-
-  CALL get_field("ZSIG", zsig)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zsig(i), xmin)
-     xmax = MAX(zsig(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
-
-  CALL get_field("ZGAM", zgam)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zgam(i), xmin)
-     xmax = MAX(zgam(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
-
-  CALL get_field("ZTHE", zthe)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zthe(i), xmin)
-     xmax = MAX(zthe(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
-
-  CALL get_field("ZPIC", zpic)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zpic(i), xmin)
-     xmax = MAX(zpic(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
-
-  CALL get_field("ZVAL", zval)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(zval(i), xmin)
-     xmax = MAX(zval(i), xmax)
-  ENDDO
-  PRINT*, 'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
-
-  CALL get_field("RUGSREL", rugoro)
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  DO i = 1, klon
-     xmin = MIN(rugoro(i), xmin)
-     xmax = MAX(rugoro(i), xmax)
-  ENDDO
-  PRINT*, 'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
-
-  ancien_ok = .TRUE.
-
-  CALL get_field("TANCIEN", t_ancien, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ancien_ok = .FALSE.
-  ENDIF
-
-  CALL get_field("QANCIEN", q_ancien, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ancien_ok = .FALSE.
-  ENDIF
-
-  CALL get_field("UANCIEN", u_ancien, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <UANCIEN> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ancien_ok = .FALSE.
-  ENDIF
-
-  CALL get_field("VANCIEN", v_ancien, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <VANCIEN> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ancien_ok = .FALSE.
-  ENDIF
-
-  clwcon=0.
-  CALL get_field("CLWCON", clwcon, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ CLWCON est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(clwcon)
-  xmax = MAXval(clwcon)
-  PRINT*, 'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
-
-  rnebcon = 0.
-  CALL get_field("RNEBCON", rnebcon, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ RNEBCON est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(rnebcon)
-  xmax = MAXval(rnebcon)
-  PRINT*, 'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
-
-  ! Lecture ratqs
-
-  ratqs=0.
-  CALL get_field("RATQS", ratqs, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <RATQS> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(ratqs)
-  xmax = MAXval(ratqs)
-  PRINT*, '(ecart-type) ratqs:', xmin, xmax
-
-  ! Lecture run_off_lic_0
-
-  CALL get_field("RUNOFFLIC0", run_off_lic_0, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     run_off_lic_0 = 0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(run_off_lic_0)
-  xmax = MAXval(run_off_lic_0)
-  PRINT*, '(ecart-type) run_off_lic_0:', xmin, xmax
-
-  ! Lecture de l'energie cinetique turbulente
-
-  IF (iflag_pbl>1) then
-     DO nsrf = 1, nbsrf
-        IF (nsrf.GT.99) THEN
-           PRINT*, "Trop de sous-mailles"
-           call abort_gcm("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') nsrf
-        CALL get_field("TKE"//str2, pbl_tke(:, 1:klev+1, nsrf), found)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: <TKE"//str2//"> est absent"
-           pbl_tke(:, :, nsrf)=1.e-8
-        ENDIF
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        DO k = 1, klev+1
-           DO i = 1, klon
-              xmin = MIN(pbl_tke(i, k, nsrf), xmin)
-              xmax = MAX(pbl_tke(i, k, nsrf), xmax)
-           ENDDO
-        ENDDO
-        PRINT*, 'Turbulent kinetic energyl TKE**:', nsrf, xmin, xmax
-     ENDDO
-  ENDIF
-
-! Lecture de l'ecart de TKE (w) - (x)
-!
-  IF (iflag_pbl>1 .AND. iflag_wake>=1  &
-           .AND. iflag_pbl_split >=1 ) then
-    DO nsrf = 1, nbsrf
-      IF (nsrf.GT.99) THEN
-        PRINT*, "Trop de sous-mailles"
-        call abort_gcm("phyetat0", "", 1)
-      ENDIF
-      WRITE(str2,'(i2.2)') nsrf
-      CALL get_field("DELTATKE"//str2, &
-                    wake_delta_pbl_tke(:,1:klev+1,nsrf),found)
-      IF (.NOT. found) THEN
-        PRINT*, "phyetat0: <DELTATKE"//str2//"> est absent"
-        wake_delta_pbl_tke(:,:,nsrf)=0.
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO k = 1, klev+1
-        DO i = 1, klon
-          xmin = MIN(wake_delta_pbl_tke(i,k,nsrf),xmin)
-          xmax = MAX(wake_delta_pbl_tke(i,k,nsrf),xmax)
-        ENDDO
-      ENDDO
-      PRINT*,'TKE difference (w)-(x) DELTATKE**:', nsrf, xmin, xmax
-    ENDDO
-
-  ! delta_tsurf
-
-    DO nsrf = 1, nbsrf
-       IF (nsrf.GT.99) THEN
-         PRINT*, "Trop de sous-mailles"
-         call abort_gcm("phyetat0", "", 1)
-       ENDIF
-       WRITE(str2,'(i2.2)') nsrf
-     CALL get_field("DELTA_TSURF"//str2, delta_tsurf(:,nsrf), found)
-     IF (.NOT. found) THEN
-        PRINT*, "phyetat0: Le champ <DELTA_TSURF"//str2//"> est absent"
-        PRINT*, "Depart legerement fausse. Mais je continue"
-        delta_tsurf(:,nsrf)=0.
-     ELSE
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-         DO i = 1, klon
-            xmin = MIN(delta_tsurf(i, nsrf), xmin)
-            xmax = MAX(delta_tsurf(i, nsrf), xmax)
-         ENDDO
-        PRINT*, 'delta_tsurf:', xmin, xmax
-     ENDIF
-    ENDDO  ! nsrf = 1, nbsrf
+  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1 ) then
+    found=phyetat0_srf(klev+1,wake_delta_pbl_tke,"DELTATKE","Del TKE wk/env",0.)
+    found=phyetat0_srf(1,delta_tsurf,"DELTA_TSURF","Delta Ts wk/env ",0.)
   ENDIF   !(iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1 )
 
-  ! zmax0
-  CALL get_field("ZMAX0", zmax0, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     zmax0=40.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(zmax0)
-  xmax = MAXval(zmax0)
-  PRINT*, '(ecart-type) zmax0:', xmin, xmax
-
-  !           f0(ig)=1.e-5
-  ! f0
-  CALL get_field("F0", f0, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <f0> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     f0=1.e-5
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(f0)
-  xmax = MAXval(f0)
-  PRINT*, '(ecart-type) f0:', xmin, xmax
-
-  ! sig1 or ema_work1
-
-  CALL get_field("sig1", sig1, found)
-  IF (.NOT. found) CALL get_field("EMA_WORK1", sig1, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ sig1 est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     sig1=0.
-  ELSE
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO k = 1, klev
-        DO i = 1, klon
-           xmin = MIN(sig1(i, k), xmin)
-           xmax = MAX(sig1(i, k), xmax)
-        ENDDO
-     ENDDO
-     PRINT*, 'sig1:', xmin, xmax
-  ENDIF
-
-  ! w01 or ema_work2
-
-  CALL get_field("w01", w01, found)
-  IF (.NOT. found) CALL get_field("EMA_WORK2", w01, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ w01 est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     w01=0.
-  ELSE
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO k = 1, klev
-        DO i = 1, klon
-           xmin = MIN(w01(i, k), xmin)
-           xmax = MAX(w01(i, k), xmax)
-        ENDDO
-     ENDDO
-     PRINT*, 'w01:', xmin, xmax
-  ENDIF
-
-  ! wake_deltat
-
-  CALL get_field("WAKE_DELTAT", wake_deltat, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_deltat=0.
-  ELSE
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO k = 1, klev
-        DO i = 1, klon
-           xmin = MIN(wake_deltat(i, k), xmin)
-           xmax = MAX(wake_deltat(i, k), xmax)
-        ENDDO
-     ENDDO
-     PRINT*, 'wake_deltat:', xmin, xmax
-  ENDIF
-
-  ! wake_deltaq
-
-  CALL get_field("WAKE_DELTAQ", wake_deltaq, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_deltaq=0.
-  ELSE
-     xmin = 1.0E+20
-     xmax = -1.0E+20
-     DO k = 1, klev
-        DO i = 1, klon
-           xmin = MIN(wake_deltaq(i, k), xmin)
-           xmax = MAX(wake_deltaq(i, k), xmax)
-        ENDDO
-     ENDDO
-     PRINT*, 'wake_deltaq:', xmin, xmax
-  ENDIF
-
-  ! wake_s
-
-  CALL get_field("WAKE_S", wake_s, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_s=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(wake_s)
-  xmax = MAXval(wake_s)
-  PRINT*, '(ecart-type) wake_s:', xmin, xmax
-
-  ! wake_cstar
-
-  CALL get_field("WAKE_CSTAR", wake_cstar, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_cstar=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(wake_cstar)
-  xmax = MAXval(wake_cstar)
-  PRINT*, '(ecart-type) wake_cstar:', xmin, xmax
-
-  ! wake_pe
-
-  CALL get_field("WAKE_PE", wake_pe, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_PE> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_pe=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(wake_pe)
-  xmax = MAXval(wake_pe)
-  PRINT*, '(ecart-type) wake_pe:', xmin, xmax
-
-  ! wake_fip
-
-  CALL get_field("WAKE_FIP", wake_fip, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     wake_fip=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(wake_fip)
-  xmax = MAXval(wake_fip)
-  PRINT*, '(ecart-type) wake_fip:', xmin, xmax
-
-  !  thermiques
-
-  CALL get_field("FM_THERM", fm_therm, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <fm_therm> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     fm_therm=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(fm_therm)
-  xmax = MAXval(fm_therm)
-  PRINT*, '(ecart-type) fm_therm:', xmin, xmax
-
-  CALL get_field("ENTR_THERM", entr_therm, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <entr_therm> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     entr_therm=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(entr_therm)
-  xmax = MAXval(entr_therm)
-  PRINT*, '(ecart-type) entr_therm:', xmin, xmax
-
-  CALL get_field("DETR_THERM", detr_therm, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <detr_therm> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     detr_therm=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(detr_therm)
-  xmax = MAXval(detr_therm)
-  PRINT*, '(ecart-type) detr_therm:', xmin, xmax
-
-  CALL get_field("ALE_BL", ale_bl, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <ale_bl> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ale_bl=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(ale_bl)
-  xmax = MAXval(ale_bl)
-  PRINT*, '(ecart-type) ale_bl:', xmin, xmax
-
-  CALL get_field("ALE_BL_TRIG", ale_bl_trig, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <ale_bl_trig> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     ale_bl_trig=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(ale_bl_trig)
-  xmax = MAXval(ale_bl_trig)
-  PRINT*, '(ecart-type) ale_bl_trig:', xmin, xmax
-
-  CALL get_field("ALP_BL", alp_bl, found)
-  IF (.NOT. found) THEN
-     PRINT*, "phyetat0: Le champ <alp_bl> est absent"
-     PRINT*, "Depart legerement fausse. Mais je continue"
-     alp_bl=0.
-  ENDIF
-  xmin = 1.0E+20
-  xmax = -1.0E+20
-  xmin = MINval(alp_bl)
-  xmax = MAXval(alp_bl)
-  PRINT*, '(ecart-type) alp_bl:', xmin, xmax
-
+!==================================
+!  thermiques, poches, convection
+!==================================
+
+! Emanuel
+  found=phyetat0_get(klev,sig1,"sig1","sig1",0.)
+  found=phyetat0_get(klev,w01,"w01","w01",0.)
+
+! Wake
+  found=phyetat0_get(klev,wake_deltat,"WAKE_DELTAT","Delta T wake/env",0.)
+  found=phyetat0_get(klev,wake_deltaq,"WAKE_DELTAQ","Delta hum. wake/env",0.)
+  found=phyetat0_get(1,wake_s,"WAKE_S","WAKE_S",0.)
+  found=phyetat0_get(1,wake_cstar,"WAKE_CSTAR","WAKE_CSTAR",0.)
+  found=phyetat0_get(1,wake_pe,"WAKE_PE","WAKE_PE",0.)
+  found=phyetat0_get(1,wake_fip,"WAKE_FIP","WAKE_FIP",0.)
+
+! Thermiques
+  found=phyetat0_get(1,zmax0,"ZMAX0","ZMAX0",40.)
+  found=phyetat0_get(1,f0,"F0","F0",1.e-5)
+  found=phyetat0_get(klev+1,fm_therm,"FM_THERM","Thermals mass flux",0.)
+  found=phyetat0_get(klev,entr_therm,"ENTR_THERM","Thermals Entrain.",0.)
+  found=phyetat0_get(klev,detr_therm,"DETR_THERM","Thermals Detrain.",0.)
+
+! ALE/ALP
+  found=phyetat0_get(1,ale_bl,"ALE_BL","ALE BL",0.)
+  found=phyetat0_get(1,ale_bl_trig,"ALE_BL_TRIG","ALE BL_TRIG",0.)
+  found=phyetat0_get(1,alp_bl,"ALP_BL","ALP BL",0.)
+
+!===========================================
   ! Read and send field trs to traclmdz
+!===========================================
 
   IF (type_trac == 'lmdz') THEN
-     DO it=1, nbtr
-        iiq=niadv(it+2)
-        CALL get_field("trs_"//tname(iiq), trs(:, it), found)
-        IF (.NOT. found) THEN
-           PRINT*,  &
-                "phyetat0: Le champ <trs_"//tname(iiq)//"> est absent"
-           PRINT*, "Depart legerement fausse. Mais je continue"
-           trs(:, it) = 0.
-        ENDIF
-        xmin = 1.0E+20
-        xmax = -1.0E+20
-        xmin = MINval(trs(:, it))
-        xmax = MAXval(trs(:, it))
-        PRINT*, "(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax
-
+     DO it=1, nbtr                                                                  
+!!        iiq=niadv(it+2)                                                           ! jyg
+        iiq=niadv(it+nqo)                                                           ! jyg
+        found=phyetat0_get(1,trs(:,it),"trs_"//tname(iiq), &
+              "Surf trac"//tname(iiq),0.)
      END DO
      CALL traclmdz_from_restart(trs)
@@ -1166,35 +359,37 @@
      IF (carbon_cycle_cpl) THEN
         ALLOCATE(co2_send(klon), stat=ierr)
-        IF (ierr /= 0) CALL abort_gcm &
-             ('phyetat0', 'pb allocation co2_send', 1)
-        CALL get_field("co2_send", co2_send, found)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: Le champ <co2_send> est absent"
-           PRINT*, "Initialisation uniforme a co2_ppm=", co2_ppm
-           co2_send(:) = co2_ppm
-        END IF
+        IF (ierr /= 0) CALL abort_gcm('phyetat0', 'pb allocation co2_send', 1)
+        found=phyetat0_get(1,co2_send,"co2_send","co2 send",0.)
      END IF
   END IF
 
+!===========================================
+!  ondes de gravite / relief
+!===========================================
+
+!  ondes de gravite non orographiques
   if (ok_gwd_rando) then
-     call get_field("du_gwd_rando", du_gwd_rando, found)
-     if (.not. found) then
-        print *, "du_gwd_rando not found, setting it to 0."
-        du_gwd_rando = 0.
-     end if
-
-     call get_field("dv_gwd_rando", dv_gwd_rando, found)
-     if (.not. found) then
-        print *, "dv_gwd_rando not found, setting it to 0."
-        dv_gwd_rando = 0.
-     end if
+     found=phyetat0_get(klev,du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.)
+     found=phyetat0_get(klev,dv_gwd_rando,"dv_gwd_rando","dv_gwd_rando",0.)
   end if
 
-  ! Initialize Slab variables
+!  prise en compte du relief sous-maille
+  found=phyetat0_get(1,zmea,"ZMEA","sub grid orography",0.)
+  found=phyetat0_get(1,zstd,"ZSTD","sub grid orography",0.)
+  found=phyetat0_get(1,zsig,"ZSIG","sub grid orography",0.)
+  found=phyetat0_get(1,zgam,"ZGAM","sub grid orography",0.)
+  found=phyetat0_get(1,zthe,"ZTHE","sub grid orography",0.)
+  found=phyetat0_get(1,zpic,"ZPIC","sub grid orography",0.)
+  found=phyetat0_get(1,zval,"ZVAL","sub grid orography",0.)
+  found=phyetat0_get(1,zmea,"ZMEA","sub grid orography",0.)
+  found=phyetat0_get(1,rugoro,"RUGSREL","sub grid orography",0.)
+
+!===========================================
+! Initialize ocean
+!===========================================
+
   IF ( type_ocean == 'slab' ) THEN
-      print*, "calling slab_init"
       CALL ocean_slab_init(dtime, pctsrf)
-      ! tslab
-      CALL get_field("tslab", tslab, found)
+      found=phyetat0_get(nslay,tslab,"tslab","tslab",0.)
       IF (.NOT. found) THEN 
           PRINT*, "phyetat0: Le champ <tslab> est absent"
@@ -1204,7 +399,8 @@
           END DO
       END IF 
+
       ! Sea ice variables
+      found=phyetat0_get(1,tice,"slab_tice","slab_tice",0.)
       IF (version_ocean == 'sicINT') THEN
-          CALL get_field("slab_tice", tice, found)
           IF (.NOT. found) THEN 
               PRINT*, "phyetat0: Le champ <tice> est absent"
@@ -1212,5 +408,4 @@
                   tice(:)=ftsol(:,is_sic)
           END IF 
-          CALL get_field("seaice", seaice, found)
           IF (.NOT. found) THEN
               PRINT*, "phyetat0: Le champ <seaice> est absent"
@@ -1229,6 +424,5 @@
   ! Initialize module pbl_surface_mod 
 
-  CALL pbl_surface_init(qsol, fder, snow, qsurf, &
-       evap, frugs, agesno, tsoil)
+  CALL pbl_surface_init(fder, snow, qsurf, tsoil)
 
   ! Initialize module ocean_cpl_mod for the case of coupled ocean
@@ -1243,2 +437,85 @@
 
 END SUBROUTINE phyetat0
+
+!===================================================================
+FUNCTION phyetat0_get(nlev,field,name,descr,default)
+!===================================================================
+! Lecture d'un champ avec contrôle
+! Function logique dont le resultat indique si la lecture
+! s'est bien passée
+! On donne une valeur par defaut dans le cas contraire
+!===================================================================
+
+USE iostart, ONLY : get_field
+USE dimphy, only: klon 
+
+IMPLICIT NONE
+INCLUDE "iniprint.h"
+
+LOGICAL phyetat0_get
+
+! arguments
+INTEGER,INTENT(IN) :: nlev
+CHARACTER*(*),INTENT(IN) :: name,descr
+REAL,INTENT(IN) :: default
+REAL,DIMENSION(klon,nlev),INTENT(INOUT) :: field
+
+! Local variables
+LOGICAL found
+
+   CALL get_field(name, field, found)
+   IF (.NOT. found) THEN
+     WRITE(lunout,*) "phyetat0: Le champ <",name,"> est absent"
+     WRITE(lunout,*) "Depart legerement fausse. Mais je continue"
+     field(:,:)=default
+   ENDIF
+   WRITE(lunout,*) name, descr, MINval(field),MAXval(field)
+   phyetat0_get=found
+
+RETURN
+END FUNCTION phyetat0_get
+
+!================================================================
+FUNCTION phyetat0_srf(nlev,field,name,descr,default)
+!===================================================================
+! Lecture d'un champ par sous-surface avec contrôle
+! Function logique dont le resultat indique si la lecture
+! s'est bien passée
+! On donne une valeur par defaut dans le cas contraire
+!===================================================================
+
+USE iostart, ONLY : get_field
+USE dimphy, only: klon 
+USE indice_sol_mod, only: nbsrf
+
+IMPLICIT NONE
+INCLUDE "iniprint.h"
+
+LOGICAL phyetat0_srf
+! arguments
+INTEGER,INTENT(IN) :: nlev
+CHARACTER*(*),INTENT(IN) :: name,descr
+REAL,INTENT(IN) :: default
+REAL,DIMENSION(klon,nlev,nbsrf),INTENT(INOUT) :: field
+
+! Local variables
+LOGICAL found,phyetat0_get
+INTEGER nsrf
+CHARACTER*2 str2
+  
+     IF (nbsrf.GT.99) THEN
+        WRITE(lunout,*) "Trop de sous-mailles"
+        call abort_gcm("phyetat0", "", 1)
+     ENDIF
+
+     DO nsrf = 1, nbsrf
+        WRITE(str2, '(i2.2)') nsrf
+        found= phyetat0_get(nlev,field(:,:, nsrf), &
+        name//str2,descr//" srf:"//str2,default)
+     ENDDO
+
+     phyetat0_srf=found
+
+RETURN
+END FUNCTION phyetat0_srf
+
Index: LMDZ5/branches/testing/libf/phylmd/phyredem.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phyredem.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phyredem.F90	(revision 2298)
@@ -36,10 +36,6 @@
   REAL tsoil(klon, nsoilmx, nbsrf)
   REAL qsurf(klon, nbsrf)
-  REAL qsol(klon)
   REAL snow(klon, nbsrf)
-  REAL evap(klon, nbsrf)
   real fder(klon)
-  REAL frugs(klon, nbsrf)
-  REAL agesno(klon, nbsrf)
   REAL run_off_lic_0(klon)
   REAL trs(klon, nbtr)
@@ -60,6 +56,5 @@
   ! Get variables which will be written to restart file from module 
   ! pbl_surface_mod
-  CALL pbl_surface_final(qsol, fder, snow, qsurf,  &
-       evap, frugs, agesno, tsoil)
+  CALL pbl_surface_final(fder, snow, qsurf,  tsoil)
 
   ! Get a variable calculated in module fonte_neige_mod
@@ -190,28 +185,6 @@
      IF (nsrf.LE.99) THEN
         WRITE(str2, '(i2.2)') nsrf
-        CALL put_field("ALBE"//str2, "albedo de surface No."//str2, &
-             falb1(:, nsrf))
-     ELSE
-        PRINT*, "Trop de sous-mailles"
-        call abort_gcm("phyredem", "", 1)
-     ENDIF
-  ENDDO
-
-  DO nsrf = 1, nbsrf
-     IF (nsrf.LE.99) THEN
-        WRITE(str2, '(i2.2)') nsrf
-        CALL put_field("ALBLW"//str2, "albedo LW de surface No."//str2, &
-             falb2(:, nsrf))
-     ELSE
-        PRINT*, "Trop de sous-mailles"
-        call abort_gcm("phyredem", "", 1)
-     ENDIF
-  ENDDO
-
-  DO nsrf = 1, nbsrf
-     IF (nsrf.LE.99) THEN
-        WRITE(str2, '(i2.2)') nsrf
         CALL put_field("EVAP"//str2, "Evaporation de surface No."//str2 &
-             , evap(:, nsrf))
+             , fevap(:, nsrf))
      ELSE
         PRINT*, "Trop de sous-mailles"
@@ -248,6 +221,8 @@
      IF (nsrf.LE.99) THEN
         WRITE(str2, '(i2.2)') nsrf
-        CALL put_field("RUG"//str2, "rugosite de surface No."//str2, &
-             frugs(:, nsrf))
+        CALL put_field("Z0m"//str2, "rugosite de surface No."//str2, &
+             z0m(:, nsrf))
+        CALL put_field("Z0h"//str2, "rugosite de surface No."//str2, &
+             z0h(:, nsrf))
      ELSE
         PRINT*, "Trop de sous-mailles"
@@ -291,7 +266,4 @@
 
   CALL put_field("VANCIEN", "", v_ancien)
-
-  CALL put_field("RUGMER", "Longueur de rugosite sur mer", &
-       frugs(:, is_oce))
 
   CALL put_field("CLWCON", "Eau liquide convective", clwcon)
@@ -313,4 +285,6 @@
            CALL put_field("TKE"//str2, "Energ. Cineti. Turb."//str2, &
                 pbl_tke(:, 1:klev+1, nsrf))
+           CALL put_field("DELTATKE"//str2, "Del TKE wk/env."//str2, &
+                wake_delta_pbl_tke(:, 1:klev+1, nsrf))
         ELSE
            PRINT*, "Trop de sous-mailles"
@@ -363,5 +337,6 @@
      CALL traclmdz_to_restart(trs)
      DO it=1, nbtr
-        iiq=niadv(it+2)
+!!        iiq=niadv(it+2)                                                           ! jyg
+        iiq=niadv(it+nqo)                                                           ! jyg
         CALL put_field("trs_"//tname(iiq), "", trs(:, it))
      END DO
Index: LMDZ5/branches/testing/libf/phylmd/phys_local_var_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phys_local_var_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phys_local_var_mod.F90	(revision 2298)
@@ -239,6 +239,6 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cdragm, cdragh
 !$OMP THREADPRIVATE(cdragm, cdragh)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldh, cldl, cldm, cldq, cldt, qsat2m, qsol
-!$OMP THREADPRIVATE(cldh, cldl, cldm, cldq, cldt, qsat2m, qsol)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldh, cldl, cldm, cldq, cldt, qsat2m
+!$OMP THREADPRIVATE(cldh, cldl, cldm, cldq, cldt, qsat2m )
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldhjn, cldljn, cldmjn,cldtjn
 !$OMP THREADPRIVATE(cldhjn, cldljn, cldmjn, cldtjn)
@@ -265,6 +265,6 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfqcalving
 !$OMP THREADPRIVATE(zxfqcalving)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxrugs, zxtsol, snow_lsc, zxfqfonte
-!$OMP THREADPRIVATE(zxfluxlat, zxrugs, zxtsol, snow_lsc, zxfqfonte)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxtsol, snow_lsc, zxfqfonte
+!$OMP THREADPRIVATE(zxfluxlat, zxtsol, snow_lsc, zxfqfonte)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxqsurf, rain_lsc
 !$OMP THREADPRIVATE(zxqsurf, rain_lsc)
@@ -328,6 +328,6 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: fsolsw, wfbils, wfbilo
 !$OMP THREADPRIVATE(fsolsw, wfbils, wfbilo)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: t2m, fevap, fluxlat, fsollw,evap_pot
-!$OMP THREADPRIVATE(t2m, fevap, fluxlat, fsollw,evap_pot)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: t2m, fluxlat, fsollw,evap_pot
+!$OMP THREADPRIVATE(t2m, fluxlat, fsollw,evap_pot)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dnwd, dnwd0, upwd, omega
 !$OMP THREADPRIVATE(dnwd, dnwd0, upwd, omega)
@@ -343,6 +343,4 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: wake_omg, zx_rh
 !$OMP THREADPRIVATE(wake_omg, zx_rh)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: frugs, agesno
-!$OMP THREADPRIVATE(frugs, agesno)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: pmflxr, pmflxs, prfl, psfl, fraca
 !$OMP THREADPRIVATE(pmflxr, pmflxs, prfl, psfl, fraca)
@@ -501,5 +499,5 @@
       ALLOCATE(ale_wake(klon), alp_wake(klon), bils(klon))
       ALLOCATE(cdragm(klon), cdragh(klon), cldh(klon), cldl(klon))
-      ALLOCATE(cldm(klon), cldq(klon), cldt(klon), qsat2m(klon), qsol(klon))
+      ALLOCATE(cldm(klon), cldq(klon), cldt(klon), qsat2m(klon))
       ALLOCATE(cldhjn(klon), cldljn(klon), cldmjn(klon), cldtjn(klon))
       ALLOCATE(JrNt(klon))
@@ -516,5 +514,5 @@
       ALLOCATE(slab_wfbils(klon), tpot(klon), tpote(klon), ue(klon))
       ALLOCATE(uq(klon), ve(klon), vq(klon), zxffonte(klon))
-      ALLOCATE(zxfqcalving(klon), zxfluxlat(klon), zxrugs(klon))
+      ALLOCATE(zxfqcalving(klon), zxfluxlat(klon))
       ALLOCATE(zxtsol(klon), snow_lsc(klon), zxfqfonte(klon), zxqsurf(klon))
       ALLOCATE(rain_lsc(klon))
@@ -557,6 +555,6 @@
       ALLOCATE(pmfd(klon, klev), pmfu(klon, klev))
 
-      ALLOCATE(t2m(klon, nbsrf), fevap(klon, nbsrf), fluxlat(klon, nbsrf))
-      ALLOCATE(frugs(klon, nbsrf), agesno(klon, nbsrf), fsollw(klon, nbsrf))
+      ALLOCATE(t2m(klon, nbsrf), fluxlat(klon, nbsrf))
+      ALLOCATE(fsollw(klon, nbsrf))
       ALLOCATE(fsolsw(klon, nbsrf), wfbils(klon, nbsrf), wfbilo(klon, nbsrf))
       ALLOCATE(evap_pot(klon, nbsrf))
@@ -701,5 +699,5 @@
       DEALLOCATE(ale_wake, alp_wake, bils)
       DEALLOCATE(cdragm, cdragh, cldh, cldl)
-      DEALLOCATE(cldm, cldq, cldt, qsat2m, qsol)
+      DEALLOCATE(cldm, cldq, cldt, qsat2m)
       DEALLOCATE(cldljn, cldmjn, cldhjn, cldtjn, JrNt)
       DEALLOCATE(dthmin, evap, fder, plcl, plfc)
@@ -714,5 +712,5 @@
       DEALLOCATE(slab_wfbils, tpot, tpote, ue)
       DEALLOCATE(uq, ve, vq, zxffonte)
-      DEALLOCATE(zxfqcalving, zxfluxlat, zxrugs)
+      DEALLOCATE(zxfqcalving, zxfluxlat)
       DEALLOCATE(zxtsol, snow_lsc, zxfqfonte, zxqsurf)
       DEALLOCATE(rain_lsc)
@@ -755,6 +753,6 @@
       DEALLOCATE(pmfd, pmfu)
 
-      DEALLOCATE(t2m, fevap, fluxlat)
-      DEALLOCATE(frugs, agesno, fsollw, evap_pot)
+      DEALLOCATE(t2m, fluxlat)
+      DEALLOCATE(fsollw, evap_pot)
       DEALLOCATE(fsolsw, wfbils, wfbilo)
 
Index: LMDZ5/branches/testing/libf/phylmd/phys_output_ctrlout_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phys_output_ctrlout_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phys_output_ctrlout_mod.F90	(revision 2298)
@@ -74,4 +74,7 @@
       ctrl_out((/ 10, 6, 10, 10, 10, 10, 11, 11, 11 /), &
     't2m_sic', "Temp 2m "//clnsurf(4), "K", (/ ('', i=1, 9) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_gusts = ctrl_out((/ 1, 1, 1, 10, 10, 10, 11, 11, 11 /), &
+    'gusts', 'surface gustiness', 'm2/s2', (/ ('', i=1, 9) /))
 
   TYPE(ctrl_out), SAVE :: o_wind10m = ctrl_out((/ 1, 1, 1, 10, 10, 10, 11, 11, 11 /), &
@@ -541,8 +544,8 @@
   TYPE(ctrl_out), SAVE :: o_proba_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
     'proba_notrig', &
-                         'Probabilité de non-déclenchement', ' ', (/ ('', i=1, 9) /))
+                         'Probabilite de non-declenchement', ' ', (/ ('', i=1, 9) /))
   TYPE(ctrl_out), SAVE :: o_random_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
     'random_notrig', &
-                         'Tirage aléatoire de non-déclenchement', ' ', (/ ('', i=1, 9) /))
+                         'Tirage aleatoire de non-declenchement', ' ', (/ ('', i=1, 9) /))
   TYPE(ctrl_out), SAVE :: o_ale_bl_stat = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
     'ale_bl_stat', &
@@ -601,5 +604,5 @@
 
   TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_wSTDlevs     = (/                    &
-      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w850', "Vertical wind 1hPa", "Pa/s", &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w850', "Vertical wind 850hPa", "Pa/s", &
       (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w700', "Vertical wind 700hPa", "Pa/s", &
@@ -617,5 +620,5 @@
 
   TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_tSTDlevs     = (/                    &
-      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t850', "Temperature 1hPa", "K",      &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t850', "Temperature 850hPa", "K",      &
       (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t700', "Temperature 700hPa", "K",      &
@@ -633,5 +636,5 @@
 
   TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_qSTDlevs     = (/                             &
-      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q850', "Specific humidity 1hPa", &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q850', "Specific humidity 850hPa", &
       "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q700', "Specific humidity 700hPa", &
@@ -649,5 +652,5 @@
 
   TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_zSTDlevs   = (/                           &
-      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z850', "Geopotential height 1hPa",        &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z850', "Geopotential height 850hPa",        &
       "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z700', "Geopotential height 700hPa",        &
@@ -776,6 +779,8 @@
   TYPE(ctrl_out), SAVE :: o_dtsvdfi = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
     'dtsvdfi', 'Boundary-layer dTs(g)', 'K/s', (/ ('', i=1, 9) /))
-  TYPE(ctrl_out), SAVE :: o_rugs = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
-    'rugs', 'rugosity', '-', (/ ('', i=1, 9) /))
+  TYPE(ctrl_out), SAVE :: o_z0m = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
+    'z0m', 'roughness length, momentum', '-', (/ ('', i=1, 9) /))
+  TYPE(ctrl_out), SAVE :: o_z0h = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
+    'z0h', 'roughness length, enthalpy', '-', (/ ('', i=1, 9) /))
   TYPE(ctrl_out), SAVE :: o_topswad = ctrl_out((/ 2, 10, 10, 10, 10, 10, 11, 11, 11 /), &
     'topswad', 'ADE at TOA', 'W/m2', (/ ('', i=1, 9) /))
@@ -1021,9 +1026,15 @@
       ctrl_out((/ 3, 10, 10, 10, 10, 10, 11, 11, 11 /),'snow_sic',"Snow", "kg/m2", (/ ('', i=1, 9) /)) /)
 
-  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_rugs_srf     = (/ &
-      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
-      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
-      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
-      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_z0m_srf     = (/ &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_z0h_srf     = (/ &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
 
   TYPE(ctrl_out), SAVE :: o_alb1 = ctrl_out((/ 3, 10, 10, 10, 10, 10, 11, 11, 11 /), &
Index: LMDZ5/branches/testing/libf/phylmd/phys_output_write_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phys_output_write_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phys_output_write_mod.F90	(revision 2298)
@@ -32,5 +32,5 @@
          o_t2m_min_mon, o_t2m_max_mon, &
          o_q2m, o_ustar, o_u10m, o_v10m, &
-         o_wind10m, o_wind10max, o_sicf, &
+         o_wind10m, o_wind10max, o_gusts, o_sicf, &
          o_psol, o_mass, o_qsurf, o_qsol, &
          o_precip, o_ndayrain, o_plul, o_pluc, &
@@ -88,5 +88,5 @@
          o_SWdownOR, o_LWdownOR, o_snowl, &
          o_solldown, o_dtsvdfo, o_dtsvdft, &
-         o_dtsvdfg, o_dtsvdfi, o_rugs, o_od550aer, &
+         o_dtsvdfg, o_dtsvdfi, o_z0m, o_z0h, o_od550aer, &
          o_od865aer, o_absvisaer, o_od550lt1aer, &
          o_sconcso4, o_sconcno3, o_sconcoa, o_sconcbc, &
@@ -113,5 +113,5 @@
          o_zfull, o_zhalf, o_rneb, o_rnebjn, o_rnebcon, &
          o_rnebls, o_rhum, o_ozone, o_ozone_light, &
-         o_dtphy, o_dqphy, o_albe_srf, o_rugs_srf, &
+         o_dtphy, o_dqphy, o_albe_srf, o_z0m_srf, o_z0h_srf, &
          o_ages_srf, o_snow_srf, o_alb1, o_alb2, o_tke, &
          o_tke_max, o_kz, o_kz_max, o_clwcon, &
@@ -154,4 +154,5 @@
 
     USE phys_state_var_mod, only: pctsrf, paire_ter, rain_fall, snow_fall, &
+         qsol, z0m, z0h, fevap, agesno, &
          nday_rain, rain_con, snow_con, &
          topsw, toplw, toplw0, swup, swdn, &
@@ -159,5 +160,5 @@
          SWdn200, SWdn200clr, LWup200, LWup200clr, &
          LWdn200, LWdn200clr, solsw, solsw0, sollw, &
-         radsol, sollw0, sollwdown, sollw, &
+         radsol, sollw0, sollwdown, sollw, gustiness, &
          sollwdownclr, lwdn0, ftsol, ustar, u10m, &
          v10m, pbl_tke, wake_delta_pbl_TKE, &
@@ -173,14 +174,17 @@
          vqsumSTD, vTsumSTD, O3daysumSTD, wqsumSTD, &
          vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, &
-         T2sumSTD, nlevSTD, du_gwd_rando, dv_gwd_rando
+         T2sumSTD, nlevSTD, du_gwd_rando, dv_gwd_rando, &
+         ulevSTD, vlevSTD, wlevSTD, philevSTD, qlevSTD, tlevSTD, &
+         rhlevSTD, O3STD, O3daySTD, uvSTD, vqSTD, vTSTD, wqSTD, &
+         vphiSTD, wTSTD, u2STD, v2STD, T2STD, missing_val_nf90
 
     USE phys_local_var_mod, only: zxfluxlat, slp, zxtsol, zt2m, &
-         t2m_min_mon, t2m_max_mon, &
-         zu10m, zv10m, zq2m, zustar, zxqsurf, qsol, &
-         rain_lsc, snow_lsc, evap, bils, sens, fder, &
+         t2m_min_mon, t2m_max_mon, evap, &
+         zu10m, zv10m, zq2m, zustar, zxqsurf, &
+         rain_lsc, snow_lsc, bils, sens, fder, &
          zxffonte, zxfqcalving, zxfqfonte, fluxu, &
          fluxv, zxsnow, qsnow, snowhgt, to_ice, &
          sissnow, runoff, albsol3_lic, evap_pot, &
-         t2m, fevap, fluxt, fluxlat, fsollw, fsolsw, &
+         t2m, fluxt, fluxlat, fsollw, fsolsw, &
          wfbils, wfbilo, cdragm, cdragh, cldl, cldm, &
          cldh, cldt, JrNt, cldljn, cldmjn, cldhjn, &
@@ -197,5 +201,5 @@
          weak_inversion, dthmin, cldtau, cldemi, &
          pmflxr, pmflxs, prfl, psfl, re, fl, rh2m, &
-         qsat2m, tpote, tpot, d_ts, zxrugs, od550aer, &
+         qsat2m, tpote, tpot, d_ts, od550aer, &
          od865aer, absvisaer, od550lt1aer, sconcso4, sconcno3, &
          sconcoa, sconcbc, sconcss, sconcdust, concso4, concno3, &
@@ -211,6 +215,10 @@
          lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop, &
          ec550aer, flwc, fiwc, t_seri, theta, q_seri, &
-         ql_seri, zphi, u_seri, v_seri, omega, cldfra, &
-         rneb, rnebjn, zx_rh, frugs, agesno, d_t_dyn, d_q_dyn, &
+!jyg<
+!!         ql_seri, zphi, u_seri, v_seri, omega, cldfra, &
+         ql_seri, tr_seri, &
+         zphi, u_seri, v_seri, omega, cldfra, &
+!>jyg
+         rneb, rnebjn, zx_rh, d_t_dyn, d_q_dyn, &
          d_u_dyn, d_v_dyn, d_t_con, d_t_ajsb, d_t_ajs, &
          d_u_ajs, d_v_ajs, &
@@ -243,5 +251,5 @@
     ! ug Pour les sorties XIOS
     USE xios, ONLY: xios_update_calendar
-    USE wxios, only: wxios_closedef
+    USE wxios, only: wxios_closedef, missing_val
 #endif
     USE phys_cal_mod, only : mth_len
@@ -289,5 +297,8 @@
     INTEGER, DIMENSION(iim*jjmp1*klev) :: ndex3d
     REAL, PARAMETER :: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
-    REAL, PARAMETER :: missing_val=nf90_fill_real
+!   REAL, PARAMETER :: missing_val=nf90_fill_real
+#ifndef CPP_XIOS
+    REAL :: missing_val
+#endif
     REAL, PARAMETER :: un_jour=86400.
 
@@ -354,4 +365,6 @@
        ENDIF
        CALL histwrite_phy(o_wind10max, zx_tmp_fi2d)
+
+       CALL histwrite_phy(o_gusts, gustiness)
 
        IF (vars_defined) THEN
@@ -566,5 +579,5 @@
           ENDIF
 !jyg<
-          IF (iflag_pbl > 1) THEN
+          IF (iflag_pbl > 1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) THEN
              CALL histwrite_phy(o_dltpbltke_srf(nsrf), wake_delta_pbl_TKE(:,1:klev,nsrf))
           ENDIF
@@ -655,6 +668,10 @@
        !       ENDIF
 
+#ifdef CPP_IOIPSL
+#ifndef CPP_XIOS
+  IF (.NOT.ok_all_xml) THEN
        ! ATTENTION, LES ANCIENS HISTWRITE ONT ETES CONSERVES EN ATTENDANT MIEUX:
        ! Champs interpolles sur des niveaux de pression
+       missing_val=missing_val_nf90
        DO iff=1, nfiles
           ll=0
@@ -678,5 +695,29 @@
           ENDDO
        ENDDO
-
+  ENDIF
+#endif
+#endif
+#ifdef CPP_XIOS
+  IF(ok_all_xml) THEN
+!XIOS  CALL xios_get_field_attr("u850",default_value=missing_val)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          ll=0
+          DO k=1, nlevSTD
+             bb2=clevSTD(k) 
+             IF(bb2.EQ."850".OR.bb2.EQ."700".OR. &
+                bb2.EQ."500".OR.bb2.EQ."200".OR. &
+                bb2.EQ."100".OR. &
+                bb2.EQ."50".OR.bb2.EQ."10") THEN
+                ll=ll+1
+                CALL histwrite_phy(o_uSTDlevs(ll),ulevSTD(:,k))
+                CALL histwrite_phy(o_vSTDlevs(ll),vlevSTD(:,k))
+                CALL histwrite_phy(o_wSTDlevs(ll),wlevSTD(:,k))
+                CALL histwrite_phy(o_zSTDlevs(ll),philevSTD(:,k))
+                CALL histwrite_phy(o_qSTDlevs(ll),qlevSTD(:,k))
+                CALL histwrite_phy(o_tSTDlevs(ll),tlevSTD(:,k))
+             ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+          ENDDO
+  ENDIF
+#endif
        IF (vars_defined) THEN
           DO i=1, klon
@@ -720,9 +761,10 @@
              CALL histwrite_phy(o_dqwak, zx_tmp_fi3d)
           ENDIF ! iflag_wake>=1
-          CALL histwrite_phy(o_Vprecip, Vprecip)
           CALL histwrite_phy(o_ftd, ftd)
           CALL histwrite_phy(o_fqd, fqd)
-       ELSEIF (iflag_con.EQ.30) THEN
+       ENDIF !(iflag_con.EQ.3)
+       IF (iflag_con.EQ.3.OR.iflag_con.EQ.30) THEN
           ! sortie RomP convection descente insaturee iflag_con=30
+          ! etendue a iflag_con=3 (jyg)
           CALL histwrite_phy(o_Vprecip, Vprecip)
           CALL histwrite_phy(o_wdtrainA, wdtrainA)
@@ -808,5 +850,6 @@
        CALL histwrite_phy(o_dtsvdfg,  d_ts(:,is_lic))
        CALL histwrite_phy(o_dtsvdfi, d_ts(:,is_sic))
-       CALL histwrite_phy(o_rugs, zxrugs)
+       CALL histwrite_phy(o_z0m, z0m(:,nbsrf+1))
+       CALL histwrite_phy(o_z0h, z0h(:,nbsrf+1))
        ! OD550 per species
 !--OLIVIER
@@ -973,6 +1016,8 @@
           IF (vars_defined) zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
           CALL histwrite_phy(o_albe_srf(nsrf), zx_tmp_fi2d)
-          IF (vars_defined) zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
-          CALL histwrite_phy(o_rugs_srf(nsrf), zx_tmp_fi2d)
+          IF (vars_defined) zx_tmp_fi2d(1 : klon) = z0m( 1 : klon, nsrf)
+          CALL histwrite_phy(o_z0m_srf(nsrf), zx_tmp_fi2d)
+          IF (vars_defined) zx_tmp_fi2d(1 : klon) = z0h( 1 : klon, nsrf)
+          CALL histwrite_phy(o_z0h_srf(nsrf), zx_tmp_fi2d)
           IF (vars_defined) zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
           CALL histwrite_phy(o_ages_srf(nsrf), zx_tmp_fi2d)
@@ -1267,4 +1312,10 @@
        ENDIF
 !!!!!!!!!!!! Sorties niveaux de pression NMC !!!!!!!!!!!!!!!!!!!!
+#ifdef CPP_IOIPSL
+#ifndef CPP_XIOS
+  IF (.NOT.ok_all_xml) THEN 
+       ! ATTENTION, LES ANCIENS HISTWRITE ONT ETES CONSERVES EN ATTENDANT MIEUX:
+       ! Champs interpolles sur des niveaux de pression
+       missing_val=missing_val_nf90
        DO iff=7, nfiles
 
@@ -1330,4 +1381,74 @@
           CALL histwrite_phy(o_TxT,T2sumSTD(:,:,iff-6),iff)
        ENDDO !nfiles
+  ENDIF
+#endif
+#endif
+#ifdef CPP_XIOS
+  IF(ok_all_xml) THEN 
+!      DO iff=7, nfiles
+
+!         CALL histwrite_phy(o_tnondef,tnondef(:,:,3))
+          CALL histwrite_phy(o_ta,tlevSTD(:,:))
+          CALL histwrite_phy(o_zg,philevSTD(:,:))
+          CALL histwrite_phy(o_hus,qlevSTD(:,:))
+          CALL histwrite_phy(o_hur,rhlevSTD(:,:))
+          CALL histwrite_phy(o_ua,ulevSTD(:,:))
+          CALL histwrite_phy(o_va,vlevSTD(:,:))
+          CALL histwrite_phy(o_wap,wlevSTD(:,:))
+!         IF(vars_defined) THEN
+!            DO k=1, nlevSTD
+!               DO i=1, klon
+!                  IF(tnondef(i,k,3).NE.missing_val) THEN
+!                     IF(freq_outNMC(iff-6).LT.0) THEN
+!                        freq_moyNMC(iff-6)=(mth_len*un_jour)/freq_calNMC(iff-6)
+!                     ELSE
+!                        freq_moyNMC(iff-6)=freq_outNMC(iff-6)/freq_calNMC(iff-6)
+!                     ENDIF
+!                     zx_tmp_fi3d_STD(i,k) = (100.*tnondef(i,k,3))/freq_moyNMC(iff-6)
+!                  ELSE
+!                     zx_tmp_fi3d_STD(i,k) = missing_val
+!                  ENDIF
+!               ENDDO
+!            ENDDO
+!         ENDIF
+!         CALL histwrite_phy(o_psbg,zx_tmp_fi3d_STD)
+          IF(vars_defined) THEN
+             DO k=1, nlevSTD
+                DO i=1, klon
+                   IF(O3STD(i,k).NE.missing_val) THEN
+                      zx_tmp_fi3d_STD(i,k) = O3STD(i,k) * 1.e+9
+                   ELSE
+                      zx_tmp_fi3d_STD(i,k) = missing_val
+                   ENDIF
+                ENDDO
+             ENDDO !k=1, nlevSTD
+          ENDIF
+          CALL histwrite_phy(o_tro3,zx_tmp_fi3d_STD)
+          if (read_climoz == 2) THEN
+             IF(vars_defined) THEN
+                DO k=1, nlevSTD
+                   DO i=1, klon
+                      IF(O3daySTD(i,k).NE.missing_val) THEN
+                         zx_tmp_fi3d_STD(i,k) = O3daySTD(i,k) * 1.e+9
+                      ELSE
+                         zx_tmp_fi3d_STD(i,k) = missing_val
+                      ENDIF
+                   ENDDO
+                ENDDO !k=1, nlevSTD
+             ENDIF
+             CALL histwrite_phy(o_tro3_daylight,zx_tmp_fi3d_STD)
+          endif
+          CALL histwrite_phy(o_uxv,uvSTD(:,:))
+          CALL histwrite_phy(o_vxq,vqSTD(:,:))
+          CALL histwrite_phy(o_vxT,vTSTD(:,:))
+          CALL histwrite_phy(o_wxq,wqSTD(:,:))
+          CALL histwrite_phy(o_vxphi,vphiSTD(:,:))
+          CALL histwrite_phy(o_wxT,wTSTD(:,:))
+          CALL histwrite_phy(o_uxu,u2STD(:,:))
+          CALL histwrite_phy(o_vxv,v2STD(:,:))
+          CALL histwrite_phy(o_TxT,T2STD(:,:))
+!      ENDDO !nfiles
+  ENDIF
+#endif
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IF (nqtot.GE.nqo+1) THEN
@@ -1335,5 +1456,8 @@
               IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
 
-             CALL histwrite_phy(o_trac(iq-nqo), qx(:,:,iq))
+!jyg<
+!!             CALL histwrite_phy(o_trac(iq-nqo), qx(:,:,iq))
+             CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo))
+!>jyg
              CALL histwrite_phy(o_dtr_vdf(iq-nqo),d_tr_cl(:,:,iq-nqo))
              CALL histwrite_phy(o_dtr_the(iq-nqo),d_tr_th(:,:,iq-nqo))
@@ -1352,5 +1476,8 @@
              IF(vars_defined) THEN
                 DO k=1,klev
-                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*qx(:,k,iq)
+!jyg<
+!!                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*qx(:,k,iq)
+                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*tr_seri(:,k,iq-nqo)
+!>jyg
                 ENDDO
              ENDIF
Index: LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90	(revision 2298)
@@ -10,4 +10,5 @@
 ! Declaration des variables
       USE dimphy
+      USE netcdf, only: nf90_fill_real
       INTEGER, PARAMETER :: nlevSTD=17
       INTEGER, PARAMETER :: nlevSTD8=8
@@ -16,4 +17,5 @@
       INTEGER, PARAMETER :: napisccp=1
       INTEGER, SAVE :: radpas
+      REAL, PARAMETER :: missing_val_nf90=nf90_fill_real
 !$OMP THREADPRIVATE(radpas)
       REAL, SAVE :: dtime, solaire_etat0
@@ -24,4 +26,6 @@
       REAL, ALLOCATABLE, SAVE :: ftsol(:,:)
 !$OMP THREADPRIVATE(ftsol)
+      REAL,ALLOCATABLE,SAVE :: qsol(:),fevap(:,:),z0m(:,:),z0h(:,:),agesno(:,:)
+!$OMP THREADPRIVATE(qsol,fevap,z0m,z0h,agesno)
 !      character(len=6), SAVE :: ocean
 !!!!!!$OMP THREADPRIVATE(ocean)
@@ -304,4 +308,6 @@
       REAL,ALLOCATABLE,SAVE :: sollwdown(:)
 !$OMP THREADPRIVATE(sollwdown)
+      REAL,ALLOCATABLE,SAVE :: gustiness(:)
+!$OMP THREADPRIVATE(gustiness)
       REAL,ALLOCATABLE,SAVE :: sollwdownclr(:)
 !$OMP THREADPRIVATE(sollwdownclr)
@@ -416,4 +422,6 @@
       ALLOCATE(pctsrf(klon,nbsrf))
       ALLOCATE(ftsol(klon,nbsrf))
+      ALLOCATE(qsol(klon),fevap(klon,nbsrf))
+      ALLOCATE(z0m(klon,nbsrf+1),z0h(klon,nbsrf+1),agesno(klon,nbsrf))
       ALLOCATE(falb1(klon,nbsrf))
       ALLOCATE(falb2(klon,nbsrf))
@@ -544,4 +552,5 @@
       ALLOCATE(albplap(klon))
       ALLOCATE(solswp(klon), sollwp(klon))
+      ALLOCATE(gustiness(klon))
       ALLOCATE(sollwdownp(klon))
       ALLOCATE(topsw0p(klon),toplw0p(klon))
@@ -586,4 +595,5 @@
 
       deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
+      deallocate(qsol,fevap,z0m,z0h,agesno)
       deallocate(rain_fall, snow_fall, solsw, sollw, radsol)
       deallocate(zmea, zstd, zsig, zgam)
@@ -664,4 +674,5 @@
       deallocate(topsw, toplw)
       deallocate(sollwdown, sollwdownclr)
+      deallocate(gustiness)
       deallocate(toplwdown, toplwdownclr)
       deallocate(topsw0,toplw0,solsw0,sollw0)
Index: LMDZ5/branches/testing/libf/phylmd/physiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/physiq.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/physiq.F90	(revision 2298)
@@ -47,4 +47,8 @@
   use phyaqua_mod, only: zenang_an
   USE control_mod
+#ifdef CPP_XIOS
+  USE wxios, ONLY: missing_val, missing_val_omp
+  USE xios, ONLY: xios_get_field_attr
+#endif
 #ifdef REPROBUS
   USE CHEM_REP, ONLY : Init_chem_rep_xjour
@@ -240,4 +244,7 @@
   real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
   real wght_cvfd(klon,klev)
+#ifndef CPP_XIOS
+  REAL, SAVE :: missing_val
+#endif
   ! Variables pour le lessivage convectif
   ! RomP >>> 
@@ -316,5 +323,10 @@
   SAVE top
   !$OMP THREADPRIVATE(bas, top)
-
+  !------------------------------------------------------------------
+  ! Upmost level reached by deep convection and related variable (jyg)
+  !
+  INTEGER izero
+  INTEGER k_upper_cv
+  !------------------------------------------------------------------
   !
   !=================================================================================================
@@ -528,5 +540,8 @@
   !                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
   !
-  ! Variables locales
+  !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! Local variables
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !
   REAL rhcl(klon,klev)    ! humiditi relative ciel clair
@@ -570,5 +585,7 @@
   REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp
   real zqsat(klon,klev)
+!
   INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq
+!
   REAL t_coup
   PARAMETER (t_coup=234.0)
@@ -885,4 +902,5 @@
      igout=klon/2+1/klon
      write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
+     write(lunout,*) 'igout, rlat, rlon ',igout, rlatd(igout)*180./3.141593, rlond(igout)*180./3.141593
      write(lunout,*) &
           'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys'
@@ -904,5 +922,5 @@
 
   if (first) then 
-
+     
      !CR:nvelles variables convection/poches froides
 
@@ -957,4 +975,6 @@
   pde_u(:,:) = 0.
   aam=0.
+
+  alp_bl_conv(:)=0.
 
   torsfc=0.
@@ -1332,5 +1352,4 @@
      END IF
      !
-     !
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Nouvelle initialisation pour le rayonnement RRTM
@@ -1413,8 +1432,6 @@
   !
   CALL change_srf_frac(itap, dtime, days_elapsed+1,  &
-!albedo SB >>>
-!       pctsrf, falb1, falb2, ftsol, ustar, u10m, v10m, pbl_tke)
-       pctsrf, falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
-!albedo SB <<<
+       pctsrf, fevap, z0m, z0h, agesno,              &
+       falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
 
   ! Update time and other variables in Reprobus
@@ -1547,12 +1564,16 @@
      ENDDO
 !!! RomP >>>   td dyn traceur
-     IF (nqtot.GE.3) THEN
-        DO iq = 3, nqtot
+!!     IF (nqtot.GE.3) THEN       ! jyg
+!!        DO iq = 3, nqtot        ! jyg
+     IF (nqtot.GE.nqo+1) THEN     ! jyg
+        DO iq = nqo+1, nqtot      ! jyg
            DO k = 1, klev
               DO i = 1, klon
-                 d_tr_dyn(i,k,iq-2)= &
-                      (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime
+!!                 d_tr_dyn(i,k,iq-2)= &                                 ! jyg
+!!                      (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime    ! jyg
+                 d_tr_dyn(i,k,iq-nqo)= &                                 ! jyg
+                      (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime  ! jyg
                  !         iiq=niadv(iq)
-                 !         print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-2),"tra:",iq,tname(iiq)
+                 !         print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,tname(iiq)
               ENDDO
            ENDDO
@@ -1570,9 +1591,12 @@
      ENDDO
 !!! RomP >>>   td dyn traceur
-     IF (nqtot.GE.3) THEN
-        DO iq = 3, nqtot
+!!     IF (nqtot.GE.3) THEN                                            ! jyg
+!!        DO iq = 3, nqtot                                             ! jyg
+     IF (nqtot.GE.nqo+1) THEN                                          ! jyg
+        DO iq = nqo+1, nqtot                                           ! jyg
            DO k = 1, klev
               DO i = 1, klon
-                 d_tr_dyn(i,k,iq-2)= 0.0
+!!                 d_tr_dyn(i,k,iq-2)= 0.0                             ! jyg
+                 d_tr_dyn(i,k,iq-nqo)= 0.0                             ! jyg
               ENDDO
            ENDDO
@@ -1809,5 +1833,5 @@
   !   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
   !   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
-  !   zxrugs,    zu10m,     zv10m,   fder,
+  !   zu10m,     zv10m,   fder,
   !   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
   !   frugs,     agesno,    fsollw,  fsolsw,
@@ -1841,4 +1865,23 @@
 !>jyg+nrlmd
 !
+!-------gustiness calculation-------!
+     IF (iflag_gusts==0) THEN
+        gustiness(1:klon)=0
+     ELSE IF (iflag_gusts==1) THEN
+        do i = 1, klon
+           gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i)
+        enddo
+!     ELSE IF (iflag_gusts==2) THEN
+!        do i = 1, klon
+!           gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk*ale_wake(i) !! need to make sigma_wk accessible here
+!        enddo
+!     ELSE IF (iflag_gusts==3) THEN
+!        do i = 1, klon
+!           gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i)
+!        enddo
+     ENDIF
+
+
+
      CALL pbl_surface(  &
           dtime,     date0,     itap,    days_elapsed+1, &
@@ -1847,4 +1890,5 @@
           zsig,      sollwdown, pphi,    cldt,      &
           rain_fall, snow_fall, solsw,   sollw,     &
+          gustiness,                                &
           t_seri,    q_seri,    u_seri,  v_seri,    &
 !nrlmd+jyg<
@@ -1852,6 +1896,4 @@
 !>nrlmd+jyg
           pplay,     paprs,     pctsrf,             &
-!albedo SB >>>
-!          ftsol,falb1,falb2,ustar,u10m,v10m,wstar,  &
           ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, &
 !albedo SB <<<
@@ -1882,7 +1924,7 @@
           s_capCL,   s_oliqCL,  s_cteiCL,s_pblT, &
           s_therm,   s_trmb1,   s_trmb2, s_trmb3, &
-          zxrugs,    zustar, zu10m,     zv10m,   fder, &
+          zustar, zu10m,     zv10m,   fder, &
           zxqsurf,   rh2m,      zxfluxu, zxfluxv, &
-          frugs,     agesno,    fsollw,  fsolsw, &
+          z0m, z0h,     agesno,    fsollw,  fsolsw, &
           d_ts,      fevap,     fluxlat, t2m, &
           wfbils,    wfbilo,    fluxt,   fluxu,  fluxv, &
@@ -2151,4 +2193,5 @@
         ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Estimation d'une vitesse verticale effective pour ALP
+        if (1==0) THEN
         www(1:klon)=0.
         do k=2,klev-1
@@ -2166,4 +2209,5 @@
            if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i)
         enddo
+        ENDIF
 
 
@@ -2178,4 +2222,6 @@
               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_gcm (modname,abort_message,1)
 
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -2222,5 +2268,19 @@
      !
      IF (ok_cvl) THEN ! new driver for convectL
-
+     !
+!jyg<
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+     ! Calculate the upmost level of deep convection loops: k_upper_cv
+     !  (near 22 km)
+   izero = klon/2+1/klon
+   k_upper_cv = klev
+   DO k = klev,1,-1
+     IF (pphi(izero,k) > 22.e4) k_upper_cv = k
+   ENDDO
+   IF (prt_level .ge. 5) THEN
+     Print *, 'upmost level of deep convection loops: k_upper_cv = ',k_upper_cv
+   ENDIF
+     !
+!>jyg
         IF (type_trac == 'repr') THEN
            nbtr_tmp=ntra
@@ -2231,5 +2291,5 @@
         !c          CALL concvl (iflag_con,iflag_clos,
         CALL concvl (iflag_clos, &
-             dtime,paprs,pplay,t_undi,q_undi, &
+             dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, &
              t_wake,q_wake,wake_s, &
              u_seri,v_seri,tr_seri,nbtr_tmp, &
@@ -3382,16 +3442,4 @@
 !albedo SB <<<
 
-!albedo SB >>>
-!     DO i = 1, klon
-!        albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce) &
-!             + falb1(i,is_lic) * pctsrf(i,is_lic) &
-!             + falb1(i,is_ter) * pctsrf(i,is_ter) &
-!             + falb1(i,is_sic) * pctsrf(i,is_sic)
-!        albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce) &
-!             + falb2(i,is_lic) * pctsrf(i,is_lic) &
-!             + falb2(i,is_ter) * pctsrf(i,is_ter) &
-!             + falb2(i,is_sic) * pctsrf(i,is_sic)
-!     ENDDO
-!albedo SB <<<
 
      if (mydebug) then
@@ -3935,4 +3983,16 @@
   !IM Interpolation sur les niveaux de pression du NMC
   !   -------------------------------------------------
+#ifdef CPP_XIOS
+          !$OMP MASTER
+          !On recupere la valeur de la missing value donnee dans le xml
+          CALL xios_get_field_attr("t850",default_value=missing_val_omp)
+!         PRINT *,"ARNAUD value missing ",missing_val_omp
+          !$OMP END MASTER
+          !$OMP BARRIER
+          missing_val=missing_val_omp
+#endif
+#ifndef CPP_XIOS
+          missing_val=missing_val_nf90
+#endif
   !
   include "calcul_STDlev.h"
@@ -4313,3 +4373,4 @@
   ENDDO
   RETURN
-END SUBROUTINE gr_fi_ecrit
+  END SUBROUTINE gr_fi_ecrit
+
Index: LMDZ5/branches/testing/libf/phylmd/phytrac_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/phytrac_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/phytrac_mod.F90	(revision 2298)
@@ -769,5 +769,8 @@
              ! Liu (2001) proposed to use 1.5e-3 kg/kg
 
-             CALL lsc_scav(pdtphys,it,iflag_lscav,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
+!jyg<
+!!             CALL lsc_scav(pdtphys,it,iflag_lscav,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
+             CALL lsc_scav(pdtphys,it,iflag_lscav,aerosol,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
+!>jyg
                   beta_v1,pplay,paprs,t_seri,tr_seri,d_tr_insc,   &
                   d_tr_bcscav,d_tr_evapls,qPrls)
Index: LMDZ5/branches/testing/libf/phylmd/plevel.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/plevel.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/plevel.F90	(revision 2298)
@@ -9,4 +9,10 @@
   USE netcdf
   USE dimphy
+#ifdef CPP_IOIPSL 
+  USE phys_state_var_mod, ONLY: missing_val_nf90 
+#endif
+#ifdef CPP_XIOS
+  USE wxios, ONLY: missing_val
+#endif
   IMPLICIT NONE
 
@@ -56,7 +62,14 @@
   INTEGER i, k
 
-  REAL missing_val
+! REAL missing_val
+#ifndef CPP_XIOS
+  REAL :: missing_val
+#endif
 
-  missing_val = nf90_fill_real
+! missing_val = nf90_fill_real
+
+#ifndef CPP_XIOS
+      missing_val=missing_val_nf90
+#endif
 
   IF (first) THEN
Index: LMDZ5/branches/testing/libf/phylmd/plevel_new.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/plevel_new.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/plevel_new.F90	(revision 2298)
@@ -10,4 +10,11 @@
   USE netcdf
   USE dimphy
+#ifdef CPP_IOIPSL 
+  USE phys_state_var_mod, ONLY: missing_val_nf90
+#endif
+#ifdef CPP_XIOS
+  USE wxios, ONLY: missing_val
+#endif
+
   IMPLICIT NONE
 
@@ -58,7 +65,14 @@
   INTEGER i, k
 
-  REAL missing_val
+! REAL missing_val
+#ifndef CPP_XIOS
+  REAL :: missing_val
+#endif
 
-  missing_val = nf90_fill_real
+! missing_val = nf90_fill_real
+
+#ifndef CPP_XIOS
+      missing_val=missing_val_nf90
+#endif
 
   IF (first) THEN
Index: LMDZ5/branches/testing/libf/phylmd/screenc.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/screenc.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/screenc.F90	(revision 2298)
@@ -4,5 +4,5 @@
       SUBROUTINE screenc(klon, knon, nsrf, zxli, &
                          speed, temp, q_zref, zref, &
-                         ts, qsurf, rugos, psol, &
+                         ts, qsurf, z0m, z0h, psol, &
                          ustar, testar, qstar, okri, ri1, &
                          pref, delu, delte, delq)
@@ -30,5 +30,5 @@
 ! ts------input-R- temperature de l'air a la surface
 ! qsurf---input-R- humidite relative a la surface
-! rugos---input-R- rugosite
+! z0m, z0h---input-R- rugosite
 ! psol----input-R- pression au sol
 ! ustar---input-R- facteur d'echelle pour le vent
@@ -48,5 +48,5 @@
       REAL, dimension(klon), intent(in) :: speed, temp, q_zref
       REAL, intent(in) :: zref
-      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, z0m, z0h, psol
       REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
 !
@@ -75,5 +75,5 @@
       CALL cdrag (knon, nsrf, &
                     speed, temp, q_zref, gref, &
-                    psol, ts, qsurf, rugos, &
+                    psol, ts, qsurf, z0m, z0h, &
                     cdram, cdrah, zri1, pref)
       DO i = 1, knon
Index: LMDZ5/branches/testing/libf/phylmd/stdlevvar.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/stdlevvar.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/stdlevvar.F90	(revision 2298)
@@ -4,5 +4,5 @@
       SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
                            u1, v1, t1, q1, z1, &
-                           ts1, qsurf, rugos, psol, pat1, &
+                           ts1, qsurf, z0m, z0h, psol, pat1, &
                            t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
       IMPLICIT NONE
@@ -32,5 +32,5 @@
 ! ts1-----input-R- temperature de l'air a la surface
 ! qsurf---input-R- humidite relative a la surface
-! rugos---input-R- rugosite
+! z0m, z0h---input-R- rugosite
 ! psol----input-R- pression au sol
 ! pat1----input-R- pression au 1er niveau du modele
@@ -47,5 +47,5 @@
       LOGICAL, intent(in) :: zxli
       REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
-      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: qsurf, z0m, z0h
       REAL, dimension(klon), intent(in) :: psol, pat1
 !
@@ -103,7 +103,8 @@
 ! &                   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, ts1, qsurf, rugos, &
+ &                   psol, ts1, qsurf, z0m, z0h, &
  &                   cdram, cdrah, zri1, pref)
 
@@ -139,5 +140,5 @@
       zref = 2.0
       CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
- &                 ts1, qsurf, rugos, lmon, &
+ &                 ts1, qsurf, z0m, lmon, &
  &                 ustar, testar, qstar, zref, &
  &                 delu, delte, delq)
@@ -160,5 +161,5 @@
         CALL screenc(klon, knon, nsrf, zxli, &
  &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, rugos, psol, &           
+ &                   ts1, qsurf, z0m, z0h, psol, &           
  &                   ustar, testar, qstar, okri, ri1, &
  &                   pref, delu, delte, delq) 
@@ -241,5 +242,5 @@
       zref = 10.0
       CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
- &                 ts1, qsurf, rugos, lmon, &
+ &                 ts1, qsurf, z0m, lmon, &
  &                 ustar, testar, qstar, zref, &
  &                 delu, delte, delq)
@@ -262,5 +263,5 @@
         CALL screenc(klon, knon, nsrf, zxli, &
  &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, rugos, psol, &
+ &                   ts1, qsurf, z0m, z0h, psol, &
  &                   ustar, testar, qstar, okri, ri1, &
  &                   pref, delu, delte, delq)
Index: LMDZ5/branches/testing/libf/phylmd/surf_land_bucket_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_land_bucket_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_land_bucket_mod.F90	(revision 2298)
@@ -13,5 +13,5 @@
        tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
        spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, &
-       u1, v1, rugoro, swnet, lwnet, &
+       u1, v1, gustiness, rugoro, swnet, lwnet, &
        snow, qsol, agesno, tsoil, &
        qsurf, z0_new, alb1_new, alb2_new, evap, &
@@ -49,5 +49,5 @@
     REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
     REAL, DIMENSION(klon), INTENT(IN)       :: pref
-    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
     REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
@@ -99,5 +99,5 @@
     CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
     if (type_veget=='betaclim') then
-       CALL calbeta_clim(knon,jour,rlatd(knindex(:)),beta)
+       CALL calbeta_clim(knon,jour,rlatd(knindex(1:knon)),beta)
     endif
        
@@ -123,8 +123,8 @@
 
     CALL calcul_fluxs(knon, is_ter, dtime, &
-         tsurf, p1lay, cal, beta, tq_cdrag, pref, &
+         tsurf, p1lay, cal, beta, tq_cdrag, tq_cdrag, pref, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+         1.,petAcoef, peqAcoef, petBcoef, peqBcoef, &
          tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
     
Index: LMDZ5/branches/testing/libf/phylmd/surf_land_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_land_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_land_mod.F90	(revision 2298)
@@ -14,11 +14,8 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, & 
-       pref, u1, v1, rugoro, pctsrf, &
+       pref, u1, v1, gustiness, rugoro, pctsrf, &
        lwdown_m, q2m, t2m, &
        snow, qsol, agesno, tsoil, &
-!albedo SB >>>
-!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
-       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &   
-!albedo SB <<<
+       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &   
        qsurf, tsurf_new, dflux_s, dflux_l, &
        flux_u1, flux_v1 ) 
@@ -61,5 +58,5 @@
     REAL, DIMENSION(klon), INTENT(IN)       :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)       :: pref   ! pressure reference
-    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
     REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
@@ -76,5 +73,5 @@
 ! Output variables
 !****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
 !albedo SB >>>
 !    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
@@ -137,5 +134,5 @@
             knindex, rlon, rlat, pctsrf, &
             debut, lafin, &
-            zlev,  u1, v1, temp_air, spechum, epot_air, ccanopy, & 
+            zlev,  u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, & 
             cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, &
             precip_rain, precip_snow, lwdown_m, swnet, swdown, &
@@ -143,5 +140,6 @@
             evap, fluxsens, fluxlat, &              
             tsol_rad, tsurf_new, alb1_new, alb2_new, &
-            emis_new, z0_new, qsurf)       
+            emis_new, z0m, qsurf)       
+        z0h(1:knon)=z0m(1:knon) ! En attendant mieux
 
 !  
@@ -149,5 +147,5 @@
 !  
        DO i=1,knon
-          z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2))
+          z0m(i) = MAX(1.5e-05,SQRT(z0m(i)**2 + rugoro(i)**2))
        ENDDO
 
@@ -160,8 +158,9 @@
             tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, &
             spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, &
-            u1, v1, rugoro, swnet, lwnet, &
+            u1, v1, gustiness, rugoro, swnet, lwnet, &
             snow, qsol, agesno, tsoil, &
-            qsurf, z0_new, alb1_new, alb2_new, evap, &
+            qsurf, z0m, alb1_new, alb2_new, evap, &
             fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+        z0h(1:knon)=z0m(1:knon) ! En attendant mieux
 
     ENDIF ! ok_veget
@@ -175,5 +174,5 @@
     v0(:)=0.0
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
Index: LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_mod.F90	(revision 2298)
@@ -33,5 +33,5 @@
        knindex, rlon, rlat, pctsrf, &
        debut, lafin, &
-       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       plev,  u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, & 
        tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
        precip_rain, precip_snow, lwdown, swnet, swdown, &
@@ -115,5 +115,5 @@
     REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
     REAL, DIMENSION(klon), INTENT(IN)         :: plev
-    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay, gustiness
     REAL, DIMENSION(klon), INTENT(IN)         :: temp_air, spechum
     REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
Index: LMDZ5/branches/testing/libf/phylmd/surf_landice_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_landice_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_landice_mod.F90	(revision 2298)
@@ -15,10 +15,7 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, rugoro, pctsrf, &
+       ps, u1, v1, gustiness, rugoro, pctsrf, &
        snow, qsurf, qsol, agesno, &
-!albedo SB >>>
-!      tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, &
-       tsoil, z0_new, SFRWL, alb_dir, alb_dif, evap, fluxsens, fluxlat, &
-!albedo SB <<<
+       tsoil, z0m, z0h, SFRWL, alb_dir, alb_dif, evap, fluxsens, fluxlat, &
        tsurf_new, dflux_s, dflux_l, &
        slope, cloudf, &
@@ -59,5 +56,5 @@
     REAL, DIMENSION(klon), INTENT(IN)             :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)             :: ps
-    REAL, DIMENSION(klon), INTENT(IN)             :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)             :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
@@ -82,5 +79,5 @@
 !****************************************************************************************
     REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: z0m, z0h
 !albedo SB >>>
 !    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
@@ -182,7 +179,7 @@
           tsoil0(i,:)=tsoil(i,:)
        END DO
-	   ! Martin
-	   PRINT*, 'on appelle surf_sisvat'
-	   ! Martin
+           ! Martin
+           PRINT*, 'on appelle surf_sisvat'
+           ! Martin
        CALL surf_sisvat(knon, rlon, rlat, knindex, itime, dtime, debut, lafin, &
             rmu0, swdown, lwdown, pexner, ps, p1lay, &
@@ -194,5 +191,6 @@
             run_off_lic, evap, fluxsens, fluxlat, dflux_s, dflux_l, &        
             tsurf_new, alb1, alb2, alb3, &
-            emis_new, z0_new, qsurf)
+            emis_new, z0m, qsurf)
+       z0h(1:knon)=z0m(1:knon) ! en attendant mieux
        
        ! Suppose zero surface speed
@@ -205,5 +203,5 @@
        
        CALL calcul_flux_wind(knon, dtime, &
-            u0, v0, u1, v1, cdragm, &
+            u0, v0, u1, v1, gustiness, cdragm, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
             p1lay, temp_air, &
@@ -243,12 +241,12 @@
 
     CALL calcul_fluxs(knon, is_lic, dtime, &
-         tsurf, p1lay, cal, beta, cdragh, ps, &
+         tsurf, p1lay, cal, beta, cdragh, cdragh, ps, &
          precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+         1.,AcoefH, AcoefQ, BcoefH, BcoefQ, &
          tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
 
     CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, cdragm, &
+         u0, v0, u1, v1, gustiness, cdragm, &
          AcoefU, AcoefV, BcoefU, BcoefV, &
          p1lay, temp_air, &
@@ -290,5 +288,8 @@
 !
 !****************************************************************************************
-    z0_new(:) = MAX(1.E-3,rugoro(:))
+    z0m=1.e-3
+    z0h = z0m
+    z0m = SQRT(z0m**2+rugoro**2)
+
     END IF ! ok_snow
 
Index: LMDZ5/branches/testing/libf/phylmd/surf_ocean_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_ocean_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_ocean_mod.F90	(revision 2298)
@@ -6,18 +6,15 @@
 CONTAINS
 !
-!****************************************************************************************
+!******************************************************************************
 !
   SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, &
-       rugos, windsp, rmu0, fder, tsurf_in, &
+       windsp, rmu0, fder, tsurf_in, &
        itime, dtime, jour, knon, knindex, &
-       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       p1lay, z1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, rugoro, pctsrf, &
+       ps, u1, v1, gustiness, rugoro, pctsrf, &
        snow, qsurf, agesno, &
-!albedo SB >>>
-!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
-       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & 
-!albedo SB <<<
+       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & 
        tsurf_new, dflux_s, dflux_l, lmt_bils, &
        flux_u1, flux_v1)
@@ -41,5 +38,5 @@
 
 ! Input variables
-!****************************************************************************************
+!******************************************************************************
     INTEGER, INTENT(IN)                      :: itime, jour, knon
     INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
@@ -49,10 +46,9 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: lwnet  ! net longwave radiation at surface  
     REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
-    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
     REAL, DIMENSION(klon), INTENT(IN)        :: windsp
     REAL, DIMENSION(klon), INTENT(IN)        :: rmu0  
     REAL, DIMENSION(klon), INTENT(IN)        :: fder
     REAL, DIMENSION(klon), INTENT(IN)        :: tsurf_in
-    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay,z1lay ! pression (Pa) et altitude (m) du premier niveau
     REAL, DIMENSION(klon), INTENT(IN)        :: cdragh
     REAL, DIMENSION(klon), INTENT(IN)        :: cdragm
@@ -62,10 +58,10 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
     REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
 
 ! In/Output variables
-!****************************************************************************************
+!******************************************************************************
     REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
     REAL, DIMENSION(klon), INTENT(INOUT)     :: qsurf
@@ -73,6 +69,6 @@
 
 ! Output variables
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+!******************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
 !albedo SB >>>
 !    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
@@ -88,5 +84,5 @@
 
 ! Local variables
-!****************************************************************************************
+!******************************************************************************
     INTEGER               :: i, k
     REAL                  :: tmp
@@ -94,19 +90,37 @@
     REAL, DIMENSION(klon) :: alb_eau
     REAL, DIMENSION(klon) :: radsol
+    REAL, DIMENSION(klon) :: cdragq ! Cdrag pour l'evaporation
 
 ! End definition
-!****************************************************************************************
-
-
-!****************************************************************************************
+!******************************************************************************
+
+
+!******************************************************************************
 ! Calculate total net radiance at surface
 !
-!****************************************************************************************
+!******************************************************************************
     radsol(:) = 0.0
     radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
 
-!****************************************************************************************
+!******************************************************************************
+! Cdragq computed from cdrag
+! The difference comes only from a factor (f_z0qh_oce) on z0, so that
+! it can be computed inside surf_ocean
+! More complicated appraches may require the propagation through
+! pbl_surface of an independant cdragq variable.
+!******************************************************************************
+
+    IF ( f_z0qh_oce .ne. 1.) THEN
+! Si on suit les formulations par exemple de Tessel, on 
+! a z0h=0.4*nu/u*, z0q=0.62*nu/u*, d'ou f_z0qh_oce=0.62/0.4=1.55
+       cdragq(:)=cdragh(:)*                                      &
+       log(z1lay(:)/z0h(:))/log(z1lay(:)/(f_z0qh_oce*z0h(:)))
+    ELSE
+       cdragq(:)=cdragh(:)
+    ENDIF
+
+!******************************************************************************
 ! Switch according to type of ocean (couple, slab or forced)
-!****************************************************************************************
+!******************************************************************************
     SELECT CASE(type_ocean)
     CASE('couple')
@@ -115,8 +129,8 @@
             windsp, fder, & 
             itime, dtime, knon, knindex, &
-            p1lay, cdragh, cdragm, precip_rain, precip_snow,temp_air,spechum,& 
+            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow,temp_air,spechum,& 
             AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-            ps, u1, v1, &
+            ps, u1, v1, gustiness, &
             radsol, snow, agesno, &
             qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -126,8 +140,8 @@
        CALL ocean_slab_noice( &
             itime, dtime, jour, knon, knindex, &
-            p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,&
+            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum,&
             AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-            ps, u1, v1, tsurf_in, &
+            ps, u1, v1, gustiness, tsurf_in, &
             radsol, snow, &
             qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -137,9 +151,9 @@
        CALL ocean_forced_noice( &
             itime, dtime, jour, knon, knindex, &
-            p1lay, cdragh, cdragm, precip_rain, precip_snow, &
+            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, &
             temp_air, spechum, &
             AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-            ps, u1, v1, &
+            ps, u1, v1, gustiness, &
             radsol, snow, agesno, &
             qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -147,7 +161,7 @@
     END SELECT
 
-!****************************************************************************************
+!******************************************************************************
 ! fcodron: compute lmt_bils  forced case (same as wfbils_oce / 1.-contfracatm)
-!****************************************************************************************
+!******************************************************************************
     IF (type_ocean.NE.'slab') THEN
         lmt_bils(:)=0.
@@ -158,11 +172,8 @@
     END IF
 
-!****************************************************************************************
+!******************************************************************************
 ! Calculate albedo
-!
-!****************************************************************************************
+!******************************************************************************
 !albedo SB >>>
-
-
   if(iflag_albedo==1)then
     call ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new)
@@ -184,20 +195,31 @@
 !albedo SB <<<
 
-!****************************************************************************************
+!******************************************************************************
 ! Calculate the rugosity
-!
-!****************************************************************************************
+!******************************************************************************
+IF (iflag_z0_oce==0) THEN
     DO i = 1, knon
-       tmp = MAX(cepdu2,u1(i)**2+v1(i)**2)
-       z0_new(i) = 0.018*cdragm(i) * (u1(i)**2+v1(i)**2)/RG  &
+       tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2)
+       z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG  &
             +  0.11*14e-6 / SQRT(cdragm(i) * tmp)
-       z0_new(i) = MAX(1.5e-05,z0_new(i))
+       z0m(i) = MAX(1.5e-05,z0m(i))
     ENDDO   
-!
-!****************************************************************************************
-!    
+    z0h(1:knon)=z0m(1:knon) ! En attendant mieux
+
+ELSE IF (iflag_z0_oce==1) THEN
+    DO i = 1, knon
+       tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2)
+       z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG  &
+            + 0.11*14e-6 / SQRT(cdragm(i) * tmp)
+       z0m(i) = MAX(1.5e-05,z0m(i))
+       z0h(i)=0.4*14e-6 / SQRT(cdragm(i) * tmp)
+    ENDDO
+ELSE
+       STOP'version non prevue'
+ENDIF
+!
+!******************************************************************************
   END SUBROUTINE surf_ocean
-!
-!****************************************************************************************
+!******************************************************************************
 !
 END MODULE surf_ocean_mod
Index: LMDZ5/branches/testing/libf/phylmd/surf_seaice_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/surf_seaice_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/surf_seaice_mod.F90	(revision 2298)
@@ -17,10 +17,7 @@
        AcoefH, AcoefQ, BcoefH, BcoefQ, &
        AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, rugoro, pctsrf, &
+       ps, u1, v1, gustiness, pctsrf, &
        snow, qsurf, qsol, agesno, tsoil, &
-!albedo SB >>>
-!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
-       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &  
-!albedo SB <<<
+       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &  
        tsurf_new, dflux_s, dflux_l, &
        flux_u1, flux_v1)
@@ -60,6 +57,5 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
-    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
 
@@ -72,5 +68,5 @@
 ! Output arguments
 !****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
 !albedo SB >>>
 !    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
@@ -117,5 +113,5 @@
             AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-            ps, u1, v1, pctsrf, &
+            ps, u1, v1, gustiness, pctsrf, &
             radsol, snow, qsurf, &
             alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -128,5 +124,5 @@
           AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-          ps, u1, v1, &
+          ps, u1, v1, gustiness, &
           radsol, snow, qsurf, qsol, agesno, &
           alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -139,5 +135,5 @@
             AcoefH, AcoefQ, BcoefH, BcoefQ, &
             AcoefU, AcoefV, BcoefU, BcoefV, &
-            ps, u1, v1, &
+            ps, u1, v1, gustiness, &
             radsol, snow, qsol, agesno, tsoil, &
             qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
@@ -150,7 +146,7 @@
 !
 !****************************************************************************************
-    z0_new = 0.002
-    z0_new = SQRT(z0_new**2+rugoro**2)
 
+    z0m=z0m_seaice
+    z0h = z0h_seaice
 
 !albedo SB >>>
Index: LMDZ5/branches/testing/libf/phylmd/thermcell_plume.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/thermcell_plume.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/thermcell_plume.F90	(revision 2298)
@@ -6,6 +6,6 @@
      &           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
      &           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
-     &           ,lev_out,lunout1,igout)
-!    &           ,lev_out,lunout1,igout,zbuoy,zbuoyjam)
+    &           ,lev_out,lunout1,igout)
+!     &           ,lev_out,lunout1,igout,zbuoy,zbuoyjam)
 !--------------------------------------------------------------------------
 !thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
@@ -87,5 +87,5 @@
       real ztv_est1,ztv_est2
       real zcor,zdelta,zcvm5,qlbef
-      real zbetalpha
+      real zbetalpha, coefzlmel
       real eps
       REAL REPS,RLvCp,DDT0
@@ -396,4 +396,5 @@
         else  !   if (iflag_thermals_ed.lt.8) then
            lt=l+1
+           zlt=zlev(ig,lt)
            zdz2=zlev(ig,lt)-zlev(ig,l)
 
@@ -405,7 +406,8 @@
            zdz3=zlev(ig,lt+1)-zlt
            zltdwn=zlev(ig,lt)-zdz3/2
-
-           zbuoyjam(ig,l)=1.*RG*(((lmel+zdz3-zdz2)/zdz3)*(ztva_est(ig,l)- & 
-    &          ztv(ig,lt))/ztv(ig,lt)+((zdz2-lmel)/zdz3)*(ztva_est(ig,l)- &
+           zlmelup=zlmel+(zdz/2)
+           coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz)
+           zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- & 
+    &          ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- &
     &          ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l)
         endif !   if (iflag_thermals_ed.lt.8) then
@@ -422,4 +424,5 @@
               zdw2=afact*zbuoy(ig,l)/fact_epsilon
               zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon
+!              zdw2bis=0.5*(zdw2+zdw2bis)
               lm=Max(1,l-2)
 !              zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) &
@@ -442,5 +445,5 @@
 !    &                     (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2))
 
-	    w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2)
+	    w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2)
 
 ! Nouvelle version Arnaud
@@ -556,5 +559,5 @@
     &       mix0 * 0.1 / (zalpha+0.001)               &
     &     + zbetalpha*MAX(entr_min,                   &
-    &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon ))
+    &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon))
 
 
@@ -645,7 +648,11 @@
 !    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
 !    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
+            if (iflag_thermals_ed==8) then
+	    zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2)
+            else
 	    zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2)
+            endif
 !            zw2(ig,l+1)=Max(0.0001,(zdz/(zdz+zdzbis))*(exp(-zw2fact)* &
-!    &                     (zw2(ig,l)-zdw2bis)+zdw2)+(zdzbis/(zdz+zdzbis))* &
+!    &                     (zw2(ig,l)-zdw2)+zdw2bis)+(zdzbis/(zdz+zdzbis))* &
 !    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2bis))
 
Index: LMDZ5/branches/testing/libf/phylmd/traclmdz_mod.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/traclmdz_mod.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/traclmdz_mod.F90	(revision 2298)
@@ -174,6 +174,7 @@
     id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0
     DO it=1,nbtr
-       iiq=niadv(it+2)
-       IF ( tname(iiq) == "RN" ) THEN
+!!       iiq=niadv(it+2)                                                            ! jyg
+       iiq=niadv(it+nqo)                                                            ! jyg
+       IF ( tname(iiq) == "RN" ) THEN                                               
           id_rn=it ! radon
        ELSE IF ( tname(iiq) == "PB") THEN
@@ -293,5 +294,6 @@
 ! ----------------------------------------------
     DO it=1,nbtr
-       iiq=niadv(it+2)
+!!       iiq=niadv(it+2)                                                            ! jyg
+       iiq=niadv(it+nqo)                                                            ! jyg
        ! Test if tracer is zero everywhere. 
        ! Done by master process MPI and master thread OpenMP
Index: LMDZ5/branches/testing/libf/phylmd/undefSTD.F90
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/undefSTD.F90	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/undefSTD.F90	(revision 2298)
@@ -5,7 +5,13 @@
   USE netcdf
   USE dimphy
-  USE phys_state_var_mod ! Variables sauvegardees de la physique
+#ifdef CPP_IOIPSL 
+  USE phys_state_var_mod
+#endif
+
   IMPLICIT NONE
   include "clesphys.h"
+#ifdef CPP_IOIPSL 
+  REAL :: missing_val
+#endif
 
   ! ====================================================================
@@ -51,7 +57,10 @@
   ! REAL tnondef(klon,klevSTD,nout)
 
-  REAL missing_val
+! REAL missing_val
 
-  missing_val = nf90_fill_real
+! missing_val = nf90_fill_real
+#ifndef CPP_XIOS
+      missing_val=missing_val_nf90
+#endif
 
   DO n = 1, nout
Index: LMDZ5/branches/testing/libf/phylmd/write_histrac.h
===================================================================
--- LMDZ5/branches/testing/libf/phylmd/write_histrac.h	(revision 2274)
+++ LMDZ5/branches/testing/libf/phylmd/write_histrac.h	(revision 2298)
@@ -17,5 +17,6 @@
 !----------------
      DO it=1,nbtr
-        iiq=niadv(it+2)
+!!        iiq=niadv(it+2)                                                           ! jyg
+        iiq=niadv(it+nqo)                                                           ! jyg
 
 ! CONCENTRATIONS
Index: LMDZ5/branches/testing/libf/phymar/iniphysiq.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/iniphysiq.F90	(revision 2274)
+++ 	(revision )
@@ -1,157 +1,0 @@
-!
-! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
-!
-SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
-                     rlatu,rlonv,aire,cu,cv,                             &
-                     prad,pg,pr,pcpp,iflag_phys)
-  USE dimphy, ONLY: klev ! number of atmospheric levels
-  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
-                                        ! (on full grid)
-  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 comgeomphy, ONLY: initcomgeomphy, &
-                        airephy, & ! physics grid area (m2)
-                        cuphy, & ! cu coeff. (u_covariant = cu * u)
-                        cvphy, & ! cv coeff. (v_covariant = cv * v)
-                        rlond, & ! longitudes
-                        rlatd ! latitudes
-  USE comcstphy, ONLY: rradius, & ! planet radius (m)
-                       rr, & ! recuced gas constant: R/molar mass of atm
-                       rg, & ! gravity
-                       rcpp  ! specific heat of the atmosphere
-  USE phyaqua_mod, ONLY: iniaqua
-  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
-  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
-  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes 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
-  CHARACTER (LEN=20) :: modname='iniphysiq'
-  CHARACTER (LEN=80) :: abort_message
-  REAL :: total_area_phy, total_area_dyn
-
-
-  ! global array, on full physics grid:
-  REAL,ALLOCATABLE :: latfi(:)
-  REAL,ALLOCATABLE :: lonfi(:)
-  REAL,ALLOCATABLE :: cufi(:)
-  REAL,ALLOCATABLE :: cvfi(:)
-  REAL,ALLOCATABLE :: airefi(:)
- 
-  IF (nlayer.NE.klev) THEN
-    WRITE(lunout,*) 'STOP in ',trim(modname)
-    WRITE(lunout,*) 'Problem with dimensions :'
-    WRITE(lunout,*) 'nlayer     = ',nlayer
-    WRITE(lunout,*) 'klev   = ',klev
-    abort_message = ''
-    CALL abort_gcm (modname,abort_message,1)
-  ENDIF
-
-
-  ! Generate global arrays on full physics grid
-  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
-  ALLOCATE(airefi(klon_glo))
-
-  IF (klon_glo>1) THEN ! general case
-    ! North pole
-    latfi(1)=rlatu(1)
-    lonfi(1)=0.
-    cufi(1) = cu(1)
-    cvfi(1) = cv(1)
-    DO j=2,jjm
-      DO i=1,iim
-        latfi((j-2)*iim+1+i)= rlatu(j)
-        lonfi((j-2)*iim+1+i)= rlonv(i)
-        cufi((j-2)*iim+1+i) = cu((j-1)*iim+1+i)
-        cvfi((j-2)*iim+1+i) = cv((j-1)*iim+1+i)
-      ENDDO
-    ENDDO
-    ! South pole
-    latfi(klon_glo)= rlatu(jjm+1)
-    lonfi(klon_glo)= 0.
-    cufi(klon_glo) = cu((iim+1)*jjm+1)
-    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
-
-    ! build airefi(), mesh area on physics grid
-    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
-    ! Poles are single points on physics grid
-    airefi(1)=sum(aire(1:iim,1))
-    airefi(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(1:klon_glo))
-    IF (total_area_dyn/=total_area_phy) THEN
-      WRITE (lunout, *) 'iniphysiq: 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(1)=rlatu(1)
-    lonfi(1)=rlonv(1)
-    cufi(1)=cu(1)
-    cvfi(1)=cv(1)
-    airefi(1)=aire(1,1)
-  ENDIF ! of IF (klon_glo>1)
-
-!$OMP PARALLEL
-  ! Now generate local lon/lat/cu/cv/area arrays
-  CALL initcomgeomphy
-      
-  offset = klon_mpi_begin - 1
-  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
-  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
-  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
-  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
-  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
-
-! copy some fundamental parameters to physics
-  rradius=prad
-  rg=pg
-  rr=pr
-  rcpp=pcpp
-
-!$OMP END PARALLEL
-
-!      print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ'
-!      print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...'
-
-! Additional initializations for aquaplanets 
-!$OMP PARALLEL
-      if (iflag_phys>=100) then
-        call iniaqua(klon_omp,rlatd,rlond,iflag_phys)
-      endif
-!$OMP END PARALLEL
-
-      END
Index: LMDZ5/branches/testing/libf/phymar/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_grid_phy_lmdz.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_grid_phy_lmdz.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_mpi_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_mpi_data.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_mpi_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_mpi_transfert.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_omp_data.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_omp_data.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_omp_transfert.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_omp_transfert.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_para.F90
Index: LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ5/branches/testing/libf/phymar/mod_phys_lmdz_transfert_para.F90	(revision 2274)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_phys_lmdz_transfert_para.F90
